{-# 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.Update as CC.Update
import qualified Cardano.Chain.UTxO as CC.UTxO
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
  -> BlockNo                          -- ^ Current block number
  -> SlotNo                           -- ^ Current slot number
  -> TickedLedgerState ByronBlock mk  -- ^ Current ledger
  -> [Validated (GenTx ByronBlock)]   -- ^ Txs to include
  -> PBftIsLeader PBftByronCrypto     -- ^ Leader proof ('IsLeader')
  -> 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
  -> SlotNo                          -- ^ Current slot
  -> BlockNo                         -- ^ Current block number
  -> ChainHash ByronBlock            -- ^ Previous hash
  -> 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
  -> BlockNo                           -- ^ Current block number
  -> SlotNo                            -- ^ Current slot number
  -> TickedLedgerState ByronBlock mk   -- ^ Current ledger
  -> [Validated (GenTx ByronBlock)]    -- ^ Txs to include
  -> PBftIsLeader PBftByronCrypto      -- ^ Leader proof ('IsLeader')
  -> 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 ()