{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
-- TODO: Ledger has a few deprecations that we are ignoring for now
{-# OPTIONS_GHC -Wno-deprecations #-}

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

import qualified Cardano.Ledger.Core as Core (TopTx, Tx)
import qualified Cardano.Ledger.Core as SL
  ( blockBodySize
  , hashBlockBody
  , mkBasicBlockBody
  , txSeqBlockBodyL
  )
import qualified Cardano.Ledger.Shelley.API as SL (Block (..), extractTx)
import qualified Cardano.Protocol.TPraos.BlockHeader 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)
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.
  (ShelleyCompatible proto era, Monad m) =>
  HotKey (ProtoCrypto proto) m ->
  CanBeLeader proto ->
  ForgeBlockArgs (ShelleyBlock proto era) ->
  m (ShelleyBlock proto era)
forgeShelleyBlock :: forall (m :: * -> *) era proto.
(ShelleyCompatible proto era, Monad m) =>
HotKey (ProtoCrypto proto) m
-> CanBeLeader proto
-> ForgeBlockArgs (ShelleyBlock proto era)
-> m (ShelleyBlock proto era)
forgeShelleyBlock
  HotKey (ProtoCrypto proto) m
hotKey
  CanBeLeader proto
cbl
  ForgeBlockArgs{[Validated (GenTx (ShelleyBlock proto era))]
Maybe (PerasCert (ShelleyBlock proto era))
BlockNo
SlotNo
TickedLedgerState (ShelleyBlock proto era) EmptyMK
IsLeader (BlockProtocol (ShelleyBlock proto era))
TopLevelConfig (ShelleyBlock proto era)
fbConfig :: TopLevelConfig (ShelleyBlock proto era)
fbCurrentBlockNo :: BlockNo
fbCurrentSlotNo :: SlotNo
fbPerasCert :: Maybe (PerasCert (ShelleyBlock proto era))
fbCurrentTickedLedgerState :: TickedLedgerState (ShelleyBlock proto era) EmptyMK
fbTxs :: [Validated (GenTx (ShelleyBlock proto era))]
fbIsLeader :: IsLeader (BlockProtocol (ShelleyBlock proto era))
fbConfig :: forall blk. ForgeBlockArgs blk -> TopLevelConfig blk
fbCurrentBlockNo :: forall blk. ForgeBlockArgs blk -> BlockNo
fbCurrentSlotNo :: forall blk. ForgeBlockArgs blk -> SlotNo
fbCurrentTickedLedgerState :: forall blk. ForgeBlockArgs blk -> TickedLedgerState blk EmptyMK
fbIsLeader :: forall blk. ForgeBlockArgs blk -> IsLeader (BlockProtocol blk)
fbPerasCert :: forall blk. ForgeBlockArgs blk -> Maybe (PerasCert blk)
fbTxs :: forall blk. ForgeBlockArgs blk -> [Validated (GenTx blk)]
..} =
    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 (BlockProtocol (ShelleyBlock proto era))
fbIsLeader
          SlotNo
fbCurrentSlotNo
          BlockNo
fbCurrentBlockNo
          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 fbConfig) 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)
fbConfig

    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 TopTx era) -> Identity (StrictSeq (Tx TopTx era)))
-> BlockBody era -> Identity (BlockBody era)
forall era.
EraBlockBody era =>
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
Lens' (BlockBody era) (StrictSeq (Tx TopTx era))
SL.txSeqBlockBodyL
          ((StrictSeq (Tx TopTx era) -> Identity (StrictSeq (Tx TopTx era)))
 -> BlockBody era -> Identity (BlockBody era))
-> StrictSeq (Tx TopTx era) -> BlockBody era -> BlockBody era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Tx TopTx era] -> StrictSeq (Tx TopTx era)
forall a. [a] -> StrictSeq a
Seq.fromList ((Validated (GenTx (ShelleyBlock proto era)) -> Tx TopTx era)
-> [Validated (GenTx (ShelleyBlock proto era))] -> [Tx TopTx 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 TopTx era
extractTx [Validated (GenTx (ShelleyBlock proto era))]
fbTxs)

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

    extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Core.Tx Core.TopTx era
    extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Tx TopTx era
extractTx (ShelleyValidatedTx TxId
_txid Validated (Tx TopTx era)
vtx) = Validated (Tx TopTx era) -> Tx TopTx era
forall tx. Validated tx -> tx
SL.extractTx Validated (Tx TopTx 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) EmptyMK
    -> ChainHash (Header (ShelleyBlock proto (ZonkAny 0))))
-> TickedLedgerState (ShelleyBlock proto era) EmptyMK
-> 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) EmptyMK
    -> ChainHash (Ticked LedgerState (ShelleyBlock proto era)))
-> TickedLedgerState (ShelleyBlock proto era) EmptyMK
-> ChainHash (Header (ShelleyBlock proto (ZonkAny 0)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TickedLedgerState (ShelleyBlock proto era) EmptyMK
-> ChainHash (Ticked LedgerState (ShelleyBlock proto era))
forall (l :: LedgerStateKind) (mk :: * -> * -> *).
GetTip l =>
l mk -> ChainHash l
getTipHash
        (TickedLedgerState (ShelleyBlock proto era) EmptyMK -> PrevHash)
-> TickedLedgerState (ShelleyBlock proto era) EmptyMK -> PrevHash
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock proto era) EmptyMK
fbCurrentTickedLedgerState