{-# 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.Era as SL (hashTxSeq, toTxSeq)
import qualified Cardano.Ledger.Shelley.API as SL (Block (..), extractTx)
import qualified Cardano.Ledger.Shelley.BlockChain as SL (bBodySize)
import qualified Cardano.Protocol.TPraos.BHeader as SL
import           Control.Exception
import qualified Data.Sequence.Strict as Seq
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.Eras (EraCrypto)
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 (EraCrypto era) m
  -> CanBeLeader proto
  -> TopLevelConfig (ShelleyBlock proto era)
  -> BlockNo                                      -- ^ Current block number
  -> SlotNo                                       -- ^ Current slot number
  -> TickedLedgerState (ShelleyBlock proto era)   -- ^ Current ledger
  -> [Validated (GenTx (ShelleyBlock proto era))] -- ^ Txs to include
  -> IsLeader proto
  -> m (ShelleyBlock proto era)
forgeShelleyBlock :: forall (m :: * -> *) era proto.
(ShelleyCompatible proto era, Monad m) =>
HotKey (EraCrypto era) m
-> CanBeLeader proto
-> TopLevelConfig (ShelleyBlock proto era)
-> BlockNo
-> SlotNo
-> TickedLedgerState (ShelleyBlock proto era)
-> [Validated (GenTx (ShelleyBlock proto era))]
-> IsLeader proto
-> m (ShelleyBlock proto era)
forgeShelleyBlock
  HotKey (EraCrypto era) m
hotKey
  CanBeLeader proto
cbl
  TopLevelConfig (ShelleyBlock proto era)
cfg
  BlockNo
curNo
  SlotNo
curSlot
  TickedLedgerState (ShelleyBlock proto era)
tickedLedger
  [Validated (GenTx (ShelleyBlock proto era))]
txs
  IsLeader proto
isLeader = do
    ShelleyProtocolHeader proto
hdr <- forall proto crypto (m :: * -> *).
(ProtocolHeaderSupportsKES proto, Crypto crypto, Monad m,
 crypto ~ ProtoCrypto proto) =>
HotKey crypto m
-> CanBeLeader proto
-> IsLeader proto
-> SlotNo
-> BlockNo
-> PrevHash crypto
-> Hash crypto EraIndependentBlockBody
-> Int
-> ProtVer
-> m (ShelleyProtocolHeader proto)
mkHeader @_ @(ProtoCrypto proto) HotKey (EraCrypto era) m
HotKey (ProtoCrypto proto) m
hotKey CanBeLeader proto
cbl IsLeader proto
isLeader
      SlotNo
curSlot BlockNo
curNo PrevHash (EraCrypto era)
PrevHash (ProtoCrypto proto)
prevHash (forall era.
EraSegWits era =>
TxSeq era -> Hash (HASH (EraCrypto era)) EraIndependentBlockBody
SL.hashTxSeq @era TxSeq era
body) Int
actualBodySize ProtVer
protocolVersion
    let blk :: ShelleyBlock proto era
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
-> TxSeq era -> Block (ShelleyProtocolHeader proto) era
forall era h.
(Era era, EncCBORGroup (TxSeq era), EncCBOR h) =>
h -> TxSeq era -> Block h era
SL.Block ShelleyProtocolHeader proto
hdr TxSeq era
body
    ShelleyBlock proto era -> m (ShelleyBlock proto era)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ShelleyBlock proto era -> m (ShelleyBlock proto era))
-> ShelleyBlock proto era -> m (ShelleyBlock proto era)
forall a b. (a -> b) -> a -> b
$
      Bool -> ShelleyBlock proto era -> ShelleyBlock proto era
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (Word64 -> ShelleyBlock proto era -> Bool
forall proto era.
ShelleyCompatible proto era =>
Word64 -> ShelleyBlock proto era -> Bool
verifyBlockIntegrity (ConsensusConfig proto -> Word64
forall proto.
ProtocolHeaderSupportsKES proto =>
ConsensusConfig proto -> Word64
configSlotsPerKESPeriod (ConsensusConfig proto -> Word64)
-> ConsensusConfig proto -> Word64
forall a b. (a -> b) -> a -> b
$ TopLevelConfig (ShelleyBlock proto era)
-> ConsensusConfig (BlockProtocol (ShelleyBlock proto era))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig (ShelleyBlock proto era)
cfg) ShelleyBlock proto era
blk) (ShelleyBlock proto era -> ShelleyBlock proto era)
-> ShelleyBlock proto era -> ShelleyBlock proto era
forall a b. (a -> b) -> a -> b
$
      ShelleyBlock proto era
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 :: TxSeq era
body =
        forall era. EraSegWits era => StrictSeq (Tx era) -> TxSeq era
SL.toTxSeq @era
      (StrictSeq (Tx era) -> TxSeq era)
-> StrictSeq (Tx era) -> TxSeq era
forall a b. (a -> b) -> a -> b
$ [Tx era] -> StrictSeq (Tx era)
forall a. [a] -> StrictSeq a
Seq.fromList
      ([Tx era] -> StrictSeq (Tx era)) -> [Tx era] -> StrictSeq (Tx era)
forall a b. (a -> b) -> a -> b
$ (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 -> TxSeq era -> Int
forall era. EraSegWits era => ProtVer -> TxSeq era -> Int
SL.bBodySize ProtVer
protocolVersion TxSeq era
body

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

    prevHash :: SL.PrevHash (EraCrypto era)
    prevHash :: PrevHash (EraCrypto era)
prevHash =
        forall era proto.
(EraCrypto era ~ ProtoCrypto proto) =>
ChainHash (Header (ShelleyBlock proto era))
-> PrevHash (EraCrypto era)
toShelleyPrevHash @era @proto
      (ChainHash (Header (ShelleyBlock proto era))
 -> PrevHash (EraCrypto era))
-> (TickedLedgerState (ShelleyBlock proto era)
    -> ChainHash (Header (ShelleyBlock proto era)))
-> TickedLedgerState (ShelleyBlock proto era)
-> PrevHash (EraCrypto era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainHash (TickedLedgerState (ShelleyBlock proto era))
-> ChainHash (Header (ShelleyBlock proto era))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
ChainHash b -> ChainHash b'
castHash
      (ChainHash (TickedLedgerState (ShelleyBlock proto era))
 -> ChainHash (Header (ShelleyBlock proto era)))
-> (TickedLedgerState (ShelleyBlock proto era)
    -> ChainHash (TickedLedgerState (ShelleyBlock proto era)))
-> TickedLedgerState (ShelleyBlock proto era)
-> ChainHash (Header (ShelleyBlock proto era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TickedLedgerState (ShelleyBlock proto era)
-> ChainHash (TickedLedgerState (ShelleyBlock proto era))
forall l. GetTip l => l -> ChainHash l
getTipHash
      (TickedLedgerState (ShelleyBlock proto era)
 -> PrevHash (EraCrypto era))
-> TickedLedgerState (ShelleyBlock proto era)
-> PrevHash (EraCrypto era)
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock proto era)
tickedLedger