{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Ouroboros.Consensus.Shelley.Ledger.Forge (forgeShelleyBlock) where

import qualified Cardano.Ledger.Core as Core (Tx)
import qualified Cardano.Ledger.Core as SL (hashBlockBody, mkBasicBlockBody, txSeqBlockBodyL)
import qualified Cardano.Ledger.Shelley.API as SL (Block (..), extractTx)
import qualified Cardano.Ledger.Shelley.BlockBody as SL (bBodySize)
import qualified Cardano.Protocol.TPraos.BHeader as SL
import Control.Exception
import qualified Data.Sequence.Strict as Seq
import Lens.Micro ((&), (.~))
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.Protocol.Abstract (CanBeLeader, IsLeader)
import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey)
import Ouroboros.Consensus.Shelley.Ledger.Block
import Ouroboros.Consensus.Shelley.Ledger.Config
  ( shelleyProtocolVersion
  )
import Ouroboros.Consensus.Shelley.Ledger.Integrity
import Ouroboros.Consensus.Shelley.Ledger.Mempool
import Ouroboros.Consensus.Shelley.Protocol.Abstract
  ( ProtoCrypto
  , ProtocolHeaderSupportsKES (configSlotsPerKESPeriod)
  , mkHeader
  )

{-------------------------------------------------------------------------------
  Forging
-------------------------------------------------------------------------------}

forgeShelleyBlock ::
  forall m era proto mk.
  (ShelleyCompatible proto era, Monad m) =>
  HotKey (ProtoCrypto proto) m ->
  CanBeLeader proto ->
  TopLevelConfig (ShelleyBlock proto era) ->
  -- | Current block number
  BlockNo ->
  -- | Current slot number
  SlotNo ->
  -- | Current ledger
  TickedLedgerState (ShelleyBlock proto era) mk ->
  -- | Txs to include
  [Validated (GenTx (ShelleyBlock proto era))] ->
  IsLeader proto ->
  m (ShelleyBlock proto era)
forgeShelleyBlock :: forall (m :: * -> *) era proto (mk :: MapKind).
(ShelleyCompatible proto era, Monad m) =>
HotKey (ProtoCrypto proto) m
-> CanBeLeader proto
-> TopLevelConfig (ShelleyBlock proto era)
-> BlockNo
-> SlotNo
-> TickedLedgerState (ShelleyBlock proto era) mk
-> [Validated (GenTx (ShelleyBlock proto era))]
-> IsLeader proto
-> m (ShelleyBlock proto era)
forgeShelleyBlock
  HotKey (ProtoCrypto proto) m
hotKey
  CanBeLeader proto
cbl
  TopLevelConfig (ShelleyBlock proto era)
cfg
  BlockNo
curNo
  SlotNo
curSlot
  TickedLedgerState (ShelleyBlock proto era) mk
tickedLedger
  [Validated (GenTx (ShelleyBlock proto era))]
txs
  IsLeader proto
isLeader = do
    hdr <-
      forall proto crypto (m :: * -> *).
(ProtocolHeaderSupportsKES proto, Crypto crypto, Monad m,
 crypto ~ ProtoCrypto proto) =>
HotKey crypto m
-> CanBeLeader proto
-> IsLeader proto
-> SlotNo
-> BlockNo
-> PrevHash
-> Hash HASH EraIndependentBlockBody
-> Int
-> ProtVer
-> m (ShelleyProtocolHeader proto)
mkHeader @_ @(ProtoCrypto proto)
        HotKey (ProtoCrypto proto) m
hotKey
        CanBeLeader proto
cbl
        IsLeader proto
isLeader
        SlotNo
curSlot
        BlockNo
curNo
        PrevHash
prevHash
        (forall era.
EraBlockBody era =>
BlockBody era -> Hash HASH EraIndependentBlockBody
SL.hashBlockBody @era BlockBody era
body)
        Int
actualBodySize
        ProtVer
protocolVersion
    let blk = Block (ShelleyProtocolHeader proto) era -> ShelleyBlock proto era
forall proto era.
ShelleyCompatible proto era =>
Block (ShelleyProtocolHeader proto) era -> ShelleyBlock proto era
mkShelleyBlock (Block (ShelleyProtocolHeader proto) era -> ShelleyBlock proto era)
-> Block (ShelleyProtocolHeader proto) era
-> ShelleyBlock proto era
forall a b. (a -> b) -> a -> b
$ ShelleyProtocolHeader proto
-> BlockBody era -> Block (ShelleyProtocolHeader proto) era
forall h era. h -> BlockBody era -> Block h era
SL.Block ShelleyProtocolHeader proto
hdr BlockBody era
body
    return $
      assert (verifyBlockIntegrity (configSlotsPerKESPeriod $ configConsensus cfg) blk) $
        blk
   where
    protocolVersion :: ProtVer
protocolVersion = BlockConfig (ShelleyBlock proto era) -> ProtVer
forall proto era. BlockConfig (ShelleyBlock proto era) -> ProtVer
shelleyProtocolVersion (BlockConfig (ShelleyBlock proto era) -> ProtVer)
-> BlockConfig (ShelleyBlock proto era) -> ProtVer
forall a b. (a -> b) -> a -> b
$ TopLevelConfig (ShelleyBlock proto era)
-> BlockConfig (ShelleyBlock proto era)
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig (ShelleyBlock proto era)
cfg

    body :: BlockBody era
body =
      BlockBody era
forall era. EraBlockBody era => BlockBody era
SL.mkBasicBlockBody
        BlockBody era -> (BlockBody era -> BlockBody era) -> BlockBody era
forall a b. a -> (a -> b) -> b
& (StrictSeq (Tx era) -> Identity (StrictSeq (Tx era)))
-> BlockBody era -> Identity (BlockBody era)
forall era.
EraBlockBody era =>
Lens' (BlockBody era) (StrictSeq (Tx era))
Lens' (BlockBody era) (StrictSeq (Tx era))
SL.txSeqBlockBodyL ((StrictSeq (Tx era) -> Identity (StrictSeq (Tx era)))
 -> BlockBody era -> Identity (BlockBody era))
-> StrictSeq (Tx era) -> BlockBody era -> BlockBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Tx era] -> StrictSeq (Tx era)
forall a. [a] -> StrictSeq a
Seq.fromList ((Validated (GenTx (ShelleyBlock proto era)) -> Tx era)
-> [Validated (GenTx (ShelleyBlock proto era))] -> [Tx era]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Validated (GenTx (ShelleyBlock proto era)) -> Tx era
extractTx [Validated (GenTx (ShelleyBlock proto era))]
txs)

    actualBodySize :: Int
actualBodySize = ProtVer -> BlockBody era -> Int
forall era. EraBlockBody era => ProtVer -> BlockBody era -> Int
SL.bBodySize ProtVer
protocolVersion BlockBody era
body

    extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Core.Tx era
    extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Tx era
extractTx (ShelleyValidatedTx TxId
_txid Validated (Tx era)
vtx) = Validated (Tx era) -> Tx era
forall tx. Validated tx -> tx
SL.extractTx Validated (Tx era)
vtx

    prevHash :: SL.PrevHash
    prevHash :: PrevHash
prevHash =
      forall proto era.
ChainHash (Header (ShelleyBlock proto era)) -> PrevHash
toShelleyPrevHash @proto
        (ChainHash (Header (ShelleyBlock proto (ZonkAny 0))) -> PrevHash)
-> (TickedLedgerState (ShelleyBlock proto era) mk
    -> ChainHash (Header (ShelleyBlock proto (ZonkAny 0))))
-> TickedLedgerState (ShelleyBlock proto era) mk
-> PrevHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainHash (Ticked (LedgerState (ShelleyBlock proto era)))
-> ChainHash (Header (ShelleyBlock proto (ZonkAny 0)))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash
        (ChainHash (Ticked (LedgerState (ShelleyBlock proto era)))
 -> ChainHash (Header (ShelleyBlock proto (ZonkAny 0))))
-> (TickedLedgerState (ShelleyBlock proto era) mk
    -> ChainHash (Ticked (LedgerState (ShelleyBlock proto era))))
-> TickedLedgerState (ShelleyBlock proto era) mk
-> ChainHash (Header (ShelleyBlock proto (ZonkAny 0)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TickedLedgerState (ShelleyBlock proto era) mk
-> ChainHash (Ticked (LedgerState (ShelleyBlock proto era)))
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> ChainHash l
getTipHash
        (TickedLedgerState (ShelleyBlock proto era) mk -> PrevHash)
-> TickedLedgerState (ShelleyBlock proto era) mk -> PrevHash
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock proto era) mk
tickedLedger