/
Forge.hs
108 lines (96 loc) · 4.28 KB
/
Forge.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
{-# 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) Canonical -- ^ Current ledger
-> [Validated (GenTx (ShelleyBlock proto era))] -- ^ Txs to add in the block
-> IsLeader proto
-> m (ShelleyBlock proto era)
forgeShelleyBlock
hotKey
cbl
cfg
maxTxCapacityOverrides
curNo
curSlot
tickedLedger
txs
isLeader = do
hdr <- mkHeader @_ @(ProtoCrypto proto) hotKey cbl isLeader
curSlot curNo prevHash (SL.hashTxSeq @era body) actualBodySize (shelleyProtocolVersion $ configBlock cfg)
let blk = mkShelleyBlock $ SL.Block hdr body
return $
assert (verifyBlockIntegrity (configSlotsPerKESPeriod $ configConsensus cfg) blk) $
assertWithMsg bodySizeEstimate blk
where
body =
SL.toTxSeq @era
. Seq.fromList
. fmap extractTx
$ takeLargestPrefixThatFits maxTxCapacityOverrides tickedLedger txs
extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Core.Tx era
extractTx (ShelleyValidatedTx _txid vtx) = SL.extractTx vtx
prevHash :: SL.PrevHash (EraCrypto era)
prevHash =
toShelleyPrevHash @era @proto
. castHash
. getTipHash
$ tickedLedger
bodySizeEstimate :: Either String ()
bodySizeEstimate
| actualBodySize > estimatedBodySize + fixedBlockBodyOverhead
= throwError $
"Actual block body size > Estimated block body size + fixedBlockBodyOverhead: "
<> show actualBodySize
<> " > "
<> show estimatedBodySize
<> " + "
<> show (fixedBlockBodyOverhead :: Int)
| otherwise
= return ()
estimatedBodySize, actualBodySize :: Int
estimatedBodySize = fromIntegral $ foldl' (+) 0 $ map (txInBlockSize . txForgetValidated) txs
actualBodySize = SL.bBodySize body