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

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

import           Control.Exception
import           Control.Monad.Except
import           Data.List (foldl')
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.Util.Assert

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           Ouroboros.Consensus.Mempool.TxLimits (TxLimits)
import qualified Ouroboros.Consensus.Mempool.TxLimits as TxLimits
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, TxLimits (ShelleyBlock proto era), Monad m)
  => HotKey (EraCrypto era) m
  -> CanBeLeader proto
  -> TopLevelConfig (ShelleyBlock proto era)
  -> TxLimits.Overrides (ShelleyBlock proto era)  -- ^ How to override max tx
                                                  --   capacity defined by ledger
  -> BlockNo                                      -- ^ Current block number
  -> SlotNo                                       -- ^ Current slot number
  -> TickedLedgerState (ShelleyBlock proto era)   -- ^ Current ledger
  -> [Validated (GenTx (ShelleyBlock proto era))] -- ^ Txs to add in the block
  -> IsLeader proto
  -> m (ShelleyBlock proto era)
forgeShelleyBlock :: HotKey (EraCrypto era) m
-> CanBeLeader proto
-> TopLevelConfig (ShelleyBlock proto era)
-> Overrides (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
  Overrides (ShelleyBlock proto era)
maxTxCapacityOverrides
  BlockNo
curNo
  SlotNo
curSlot
  TickedLedgerState (ShelleyBlock proto era)
tickedLedger
  [Validated (GenTx (ShelleyBlock proto era))]
txs
  IsLeader proto
isLeader = do
    ShelleyProtocolHeader proto
hdr <- HotKey (ProtoCrypto proto) m
-> CanBeLeader proto
-> IsLeader proto
-> SlotNo
-> BlockNo
-> PrevHash (ProtoCrypto proto)
-> Hash (ProtoCrypto proto) EraIndependentBlockBody
-> Int
-> ProtVer
-> m (ShelleyProtocolHeader proto)
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 (TxSeq era -> Hash (HASH (EraCrypto era)) EraIndependentBlockBody
forall era.
SupportsSegWit era =>
TxSeq era -> Hash (HASH (Crypto era)) EraIndependentBlockBody
SL.hashTxSeq @era TxSeq era
body) Int
actualBodySize (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)
    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, ToCBORGroup (TxSeq era), ToCBOR h) =>
h -> TxSeq era -> Block h era
SL.Block ShelleyProtocolHeader proto
hdr TxSeq era
body
    ShelleyBlock proto era -> m (ShelleyBlock proto era)
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
$
      Either String ()
-> ShelleyBlock proto era -> ShelleyBlock proto era
forall a. (?callStack::CallStack) => Either String () -> a -> a
assertWithMsg Either String ()
bodySizeEstimate ShelleyBlock proto era
blk
  where

    body :: TxSeq era
body =
        SupportsSegWit era => StrictSeq (Tx era) -> TxSeq era
forall era. SupportsSegWit era => StrictSeq (Tx era) -> TxSeq era
SL.toTxSeq @era
      (StrictSeq (Tx era) -> TxSeq era)
-> ([Validated (GenTx (ShelleyBlock proto era))]
    -> StrictSeq (Tx era))
-> [Validated (GenTx (ShelleyBlock proto era))]
-> TxSeq era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tx era] -> StrictSeq (Tx era)
forall a. [a] -> StrictSeq a
Seq.fromList
      ([Tx era] -> StrictSeq (Tx era))
-> ([Validated (GenTx (ShelleyBlock proto era))] -> [Tx era])
-> [Validated (GenTx (ShelleyBlock proto era))]
-> StrictSeq (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Validated (GenTx (ShelleyBlock proto era)) -> Tx era)
-> [Validated (GenTx (ShelleyBlock proto era))] -> [Tx era]
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))] -> TxSeq era)
-> [Validated (GenTx (ShelleyBlock proto era))] -> TxSeq era
forall a b. (a -> b) -> a -> b
$ Overrides (ShelleyBlock proto era)
-> TickedLedgerState (ShelleyBlock proto era)
-> [Validated (GenTx (ShelleyBlock proto era))]
-> [Validated (GenTx (ShelleyBlock proto era))]
forall blk.
TxLimits blk =>
Overrides blk
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> [Validated (GenTx blk)]
takeLargestPrefixThatFits Overrides (ShelleyBlock proto era)
maxTxCapacityOverrides TickedLedgerState (ShelleyBlock proto era)
tickedLedger [Validated (GenTx (ShelleyBlock proto era))]
txs

    extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Core.Tx era
    extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Tx era
extractTx (ShelleyValidatedTx _txid 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 =
        (EraCrypto era ~ ProtoCrypto proto) =>
ChainHash (Header (ShelleyBlock proto era))
-> PrevHash (EraCrypto era)
forall era proto.
(EraCrypto era ~ ProtoCrypto proto) =>
ChainHash (Header (ShelleyBlock proto era))
-> PrevHash (EraCrypto era)
toShelleyPrevHash @era @proto
      (ChainHash (Header (ShelleyBlock proto era))
 -> PrevHash (ProtoCrypto proto))
-> (TickedLedgerState (ShelleyBlock proto era)
    -> ChainHash (Header (ShelleyBlock proto era)))
-> TickedLedgerState (ShelleyBlock proto era)
-> PrevHash (ProtoCrypto proto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainHash (TickedLedgerState (ShelleyBlock proto era))
-> ChainHash (Header (ShelleyBlock proto era))
forall b b'.
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 (ProtoCrypto proto))
-> TickedLedgerState (ShelleyBlock proto era)
-> PrevHash (ProtoCrypto proto)
forall a b. (a -> b) -> a -> b
$ TickedLedgerState (ShelleyBlock proto era)
tickedLedger

    bodySizeEstimate :: Either String ()
    bodySizeEstimate :: Either String ()
bodySizeEstimate
      | Int
actualBodySize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
estimatedBodySize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
forall a. Num a => a
fixedBlockBodyOverhead
      = String -> Either String ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$
          String
"Actual block body size > Estimated block body size + fixedBlockBodyOverhead: "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
actualBodySize
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" > "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
estimatedBodySize
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" + "
            String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (Int
forall a. Num a => a
fixedBlockBodyOverhead :: Int)
      | Bool
otherwise
      = () -> Either String ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    estimatedBodySize, actualBodySize :: Int
    estimatedBodySize :: Int
estimatedBodySize = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int) -> Word32 -> Int
forall a b. (a -> b) -> a -> b
$ (Word32 -> Word32 -> Word32) -> Word32 -> [Word32] -> Word32
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
(+) Word32
0 ([Word32] -> Word32) -> [Word32] -> Word32
forall a b. (a -> b) -> a -> b
$ (Validated (GenTx (ShelleyBlock proto era)) -> Word32)
-> [Validated (GenTx (ShelleyBlock proto era))] -> [Word32]
forall a b. (a -> b) -> [a] -> [b]
map (GenTx (ShelleyBlock proto era) -> Word32
forall blk. LedgerSupportsMempool blk => GenTx blk -> Word32
txInBlockSize (GenTx (ShelleyBlock proto era) -> Word32)
-> (Validated (GenTx (ShelleyBlock proto era))
    -> GenTx (ShelleyBlock proto era))
-> Validated (GenTx (ShelleyBlock proto era))
-> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx (ShelleyBlock proto era))
-> GenTx (ShelleyBlock proto era)
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated) [Validated (GenTx (ShelleyBlock proto era))]
txs
    actualBodySize :: Int
actualBodySize    = TxSeq era -> Int
forall txSeq. ToCBORGroup txSeq => txSeq -> Int
SL.bBodySize TxSeq era
body