-
Notifications
You must be signed in to change notification settings - Fork 21
/
Mempool.hs
397 lines (328 loc) · 14.8 KB
/
Mempool.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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- | Shelley mempool integration
module Ouroboros.Consensus.Shelley.Ledger.Mempool (
GenTx (..)
, SL.ApplyTxError (..)
, TxId (..)
, Validated (..)
, WithTop (..)
, fixedBlockBodyOverhead
, mkShelleyTx
, mkShelleyValidatedTx
, perTxOverhead
-- * Exported for tests
, AlonzoMeasure (..)
, fromExUnits
) where
import Cardano.Ledger.Alonzo.Core (Tx, TxSeq, bodyTxL, eraProtVerLow,
fromTxSeq, ppMaxBBSizeL, ppMaxBlockExUnitsL, sizeTxF)
import Cardano.Ledger.Alonzo.Scripts (ExUnits, ExUnits',
unWrapExUnits)
import Cardano.Ledger.Alonzo.Tx (totExUnits)
import Cardano.Ledger.Binary (Annotator (..), DecCBOR (..),
EncCBOR (..), FromCBOR (..), FullByteString (..),
ToCBOR (..), toPlainDecoder)
import qualified Cardano.Ledger.Block as SL (txid)
import Cardano.Ledger.Crypto (Crypto)
import qualified Cardano.Ledger.Shelley.API as SL
import Control.Monad.Except (Except)
import Control.Monad.Identity (Identity (..))
import Data.DerivingVia (InstantiatedAt (..))
import Data.Foldable (toList)
import Data.Measure (BoundedMeasure, Measure)
import qualified Data.Measure as Measure
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import GHC.Natural (Natural)
import Lens.Micro ((^.))
import NoThunks.Class (NoThunks (..))
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool
import qualified Ouroboros.Consensus.Mempool as Mempool
import Ouroboros.Consensus.Shelley.Eras
import Ouroboros.Consensus.Shelley.Ledger.Block
import Ouroboros.Consensus.Shelley.Ledger.Ledger
(ShelleyLedgerConfig (shelleyLedgerGlobals),
Ticked (TickedShelleyLedgerState, tickedShelleyLedgerState),
getPParams)
import Ouroboros.Consensus.Util (ShowProxy (..))
import Ouroboros.Consensus.Util.Condense
import Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR)
data instance GenTx (ShelleyBlock proto era) = ShelleyTx !(SL.TxId (EraCrypto era)) !(Tx era)
deriving stock (Generic)
deriving instance ShelleyBasedEra era => NoThunks (GenTx (ShelleyBlock proto era))
deriving instance ShelleyBasedEra era => Eq (GenTx (ShelleyBlock proto era))
instance (Typeable era, Typeable proto)
=> ShowProxy (GenTx (ShelleyBlock proto era)) where
data instance Validated (GenTx (ShelleyBlock proto era)) =
ShelleyValidatedTx
!(SL.TxId (EraCrypto era))
!(SL.Validated (Tx era))
deriving stock (Generic)
deriving instance ShelleyBasedEra era => NoThunks (Validated (GenTx (ShelleyBlock proto era)))
deriving instance ShelleyBasedEra era => Eq (Validated (GenTx (ShelleyBlock proto era)))
deriving instance ShelleyBasedEra era => Show (Validated (GenTx (ShelleyBlock proto era)))
instance (Typeable era, Typeable proto)
=> ShowProxy (Validated (GenTx (ShelleyBlock proto era))) where
type instance ApplyTxErr (ShelleyBlock proto era) = SL.ApplyTxError era
-- orphaned instance
instance Typeable era => ShowProxy (SL.ApplyTxError era) where
-- |'txInBlockSize' is used to estimate how many transactions we can grab from
-- the Mempool to put into the block we are going to forge without exceeding
-- the maximum block body size according to the ledger. If we exceed that
-- limit, we will have forged a block that is invalid according to the ledger.
-- We ourselves won't even adopt it, causing us to lose our slot, something we
-- must try to avoid.
--
-- For this reason it is better to overestimate the size of a transaction than
-- to underestimate. The only downside is that we maybe could have put one (or
-- more?) transactions extra in that block.
--
-- As the sum of the serialised transaction sizes is not equal to the size of
-- the serialised block body ('TxSeq') consisting of those transactions
-- (see cardano-node#1545 for an example), we account for some extra overhead
-- per transaction as a safety margin.
--
-- Also see 'perTxOverhead'.
fixedBlockBodyOverhead :: Num a => a
fixedBlockBodyOverhead = 1024
-- | See 'fixedBlockBodyOverhead'.
perTxOverhead :: Num a => a
perTxOverhead = 4
instance ShelleyCompatible proto era
=> LedgerSupportsMempool (ShelleyBlock proto era) where
txInvariant = const True
applyTx = applyShelleyTx
reapplyTx = reapplyShelleyTx
txsMaxBytes TickedShelleyLedgerState { tickedShelleyLedgerState = shelleyState } =
fromIntegral maxBlockBodySize - fixedBlockBodyOverhead
where
maxBlockBodySize = getPParams shelleyState ^. ppMaxBBSizeL
txInBlockSize (ShelleyTx _ tx) = txSize + perTxOverhead
where
txSize = fromIntegral $ tx ^. sizeTxF
txForgetValidated (ShelleyValidatedTx txid vtx) = ShelleyTx txid (SL.extractTx vtx)
mkShelleyTx :: forall era proto. ShelleyBasedEra era => Tx era -> GenTx (ShelleyBlock proto era)
mkShelleyTx tx = ShelleyTx (SL.txid @era (tx ^. bodyTxL)) tx
mkShelleyValidatedTx :: forall era proto.
ShelleyBasedEra era
=> SL.Validated (Tx era)
-> Validated (GenTx (ShelleyBlock proto era))
mkShelleyValidatedTx vtx = ShelleyValidatedTx txid vtx
where
txid = SL.txid @era (SL.extractTx vtx ^. bodyTxL)
newtype instance TxId (GenTx (ShelleyBlock proto era)) = ShelleyTxId (SL.TxId (EraCrypto era))
deriving newtype (Eq, Ord, NoThunks)
deriving newtype instance (Crypto (EraCrypto era), Typeable era, Typeable proto)
=> EncCBOR (TxId (GenTx (ShelleyBlock proto era)))
deriving newtype instance (Crypto (EraCrypto era), Typeable era, Typeable proto)
=> DecCBOR (TxId (GenTx (ShelleyBlock proto era)))
instance (Typeable era, Typeable proto)
=> ShowProxy (TxId (GenTx (ShelleyBlock proto era))) where
instance ShelleyBasedEra era => HasTxId (GenTx (ShelleyBlock proto era)) where
txId (ShelleyTx i _) = ShelleyTxId i
instance ShelleyBasedEra era => HasTxs (ShelleyBlock proto era) where
extractTxs =
map mkShelleyTx
. txSeqToList
. SL.bbody
. shelleyBlockRaw
where
txSeqToList :: TxSeq era -> [Tx era]
txSeqToList = toList . fromTxSeq @era
{-------------------------------------------------------------------------------
Serialisation
-------------------------------------------------------------------------------}
instance ShelleyCompatible proto era => ToCBOR (GenTx (ShelleyBlock proto era)) where
-- No need to encode the 'TxId', it's just a hash of the 'SL.TxBody' inside
-- 'SL.Tx', so it can be recomputed.
toCBOR (ShelleyTx _txid tx) = wrapCBORinCBOR toCBOR tx
instance ShelleyCompatible proto era => FromCBOR (GenTx (ShelleyBlock proto era)) where
fromCBOR = fmap mkShelleyTx $ unwrapCBORinCBOR
$ toPlainDecoder (eraProtVerLow @era) $ (. Full) . runAnnotator <$> decCBOR
{-------------------------------------------------------------------------------
Pretty-printing
-------------------------------------------------------------------------------}
instance ShelleyBasedEra era => Condense (GenTx (ShelleyBlock proto era)) where
condense (ShelleyTx _ tx ) = show tx
instance Condense (GenTxId (ShelleyBlock proto era)) where
condense (ShelleyTxId i) = "txid: " <> show i
instance ShelleyBasedEra era => Show (GenTx (ShelleyBlock proto era)) where
show = condense
instance Show (GenTxId (ShelleyBlock proto era)) where
show = condense
{-------------------------------------------------------------------------------
Applying transactions
-------------------------------------------------------------------------------}
applyShelleyTx :: forall era proto.
ShelleyBasedEra era
=> LedgerConfig (ShelleyBlock proto era)
-> WhetherToIntervene
-> SlotNo
-> GenTx (ShelleyBlock proto era)
-> TickedLedgerState (ShelleyBlock proto era)
-> Except (ApplyTxErr (ShelleyBlock proto era))
( TickedLedgerState (ShelleyBlock proto era)
, Validated (GenTx (ShelleyBlock proto era))
)
applyShelleyTx cfg wti slot (ShelleyTx _ tx) st = do
(mempoolState', vtx) <-
applyShelleyBasedTx
(shelleyLedgerGlobals cfg)
(SL.mkMempoolEnv innerSt slot)
(SL.mkMempoolState innerSt)
wti
tx
let st' = set theLedgerLens mempoolState' st
pure (st', mkShelleyValidatedTx vtx)
where
innerSt = tickedShelleyLedgerState st
reapplyShelleyTx ::
ShelleyBasedEra era
=> LedgerConfig (ShelleyBlock proto era)
-> SlotNo
-> Validated (GenTx (ShelleyBlock proto era))
-> TickedLedgerState (ShelleyBlock proto era)
-> Except (ApplyTxErr (ShelleyBlock proto era)) (TickedLedgerState (ShelleyBlock proto era))
reapplyShelleyTx cfg slot vgtx st = do
mempoolState' <-
SL.reapplyTx
(shelleyLedgerGlobals cfg)
(SL.mkMempoolEnv innerSt slot)
(SL.mkMempoolState innerSt)
vtx
pure $ set theLedgerLens mempoolState' st
where
ShelleyValidatedTx _txid vtx = vgtx
innerSt = tickedShelleyLedgerState st
-- | The lens combinator
set ::
(forall f. Applicative f => (a -> f b) -> s -> f t)
-> b -> s -> t
set lens inner outer =
runIdentity $ lens (\_ -> Identity inner) outer
theLedgerLens ::
Functor f
=> (SL.LedgerState era -> f (SL.LedgerState era))
-> TickedLedgerState (ShelleyBlock proto era)
-> f (TickedLedgerState (ShelleyBlock proto era))
theLedgerLens f x =
(\y -> x{tickedShelleyLedgerState = y})
<$> SL.overNewEpochState f (tickedShelleyLedgerState x)
{-------------------------------------------------------------------------------
Tx Limits
-------------------------------------------------------------------------------}
instance ShelleyCompatible p (ShelleyEra c) => Mempool.TxLimits (ShelleyBlock p (ShelleyEra c)) where
type TxMeasure (ShelleyBlock p (ShelleyEra c)) = Mempool.ByteSize
txMeasure = Mempool.ByteSize . txInBlockSize . txForgetValidated
txsBlockCapacity = Mempool.ByteSize . txsMaxBytes
instance ShelleyCompatible p (AllegraEra c) => Mempool.TxLimits (ShelleyBlock p (AllegraEra c)) where
type TxMeasure (ShelleyBlock p (AllegraEra c)) = Mempool.ByteSize
txMeasure = Mempool.ByteSize . txInBlockSize . txForgetValidated
txsBlockCapacity = Mempool.ByteSize . txsMaxBytes
instance ShelleyCompatible p (MaryEra c) => Mempool.TxLimits (ShelleyBlock p (MaryEra c)) where
type TxMeasure (ShelleyBlock p (MaryEra c)) = Mempool.ByteSize
txMeasure = Mempool.ByteSize . txInBlockSize . txForgetValidated
txsBlockCapacity = Mempool.ByteSize . txsMaxBytes
instance ( ShelleyCompatible p (AlonzoEra c)
) => Mempool.TxLimits (ShelleyBlock p (AlonzoEra c)) where
type TxMeasure (ShelleyBlock p (AlonzoEra c)) = AlonzoMeasure
txMeasure (ShelleyValidatedTx _txid vtx) =
AlonzoMeasure {
byteSize = Mempool.ByteSize $ txInBlockSize (mkShelleyTx @(AlonzoEra c) @p (SL.extractTx vtx))
, exUnits = fromExUnits $ totExUnits (SL.extractTx vtx)
}
txsBlockCapacity ledgerState =
AlonzoMeasure {
byteSize = Mempool.ByteSize $ txsMaxBytes ledgerState
, exUnits = fromExUnits $ pparams ^. ppMaxBlockExUnitsL
}
where
pparams = getPParams $ tickedShelleyLedgerState ledgerState
data AlonzoMeasure = AlonzoMeasure {
byteSize :: !Mempool.ByteSize
, exUnits :: !(ExUnits' (WithTop Natural))
} deriving stock (Eq, Generic, Show)
deriving (BoundedMeasure, Measure)
via (InstantiatedAt Generic AlonzoMeasure)
fromExUnits :: ExUnits -> ExUnits' (WithTop Natural)
fromExUnits = fmap NotTop . unWrapExUnits
instance ( ShelleyCompatible p (BabbageEra c)
) => Mempool.TxLimits (ShelleyBlock p (BabbageEra c)) where
type TxMeasure (ShelleyBlock p (BabbageEra c)) = AlonzoMeasure
txMeasure (ShelleyValidatedTx _txid vtx) =
AlonzoMeasure {
byteSize = Mempool.ByteSize $ txInBlockSize (mkShelleyTx @(BabbageEra c) @p (SL.extractTx vtx))
, exUnits = fromExUnits $ totExUnits (SL.extractTx vtx)
}
txsBlockCapacity ledgerState =
AlonzoMeasure {
byteSize = Mempool.ByteSize $ txsMaxBytes ledgerState
, exUnits = fromExUnits $ pparams ^. ppMaxBlockExUnitsL
}
where
pparams = getPParams $ tickedShelleyLedgerState ledgerState
instance ( ShelleyCompatible p (ConwayEra c)
) => Mempool.TxLimits (ShelleyBlock p (ConwayEra c)) where
type TxMeasure (ShelleyBlock p (ConwayEra c)) = AlonzoMeasure
txMeasure (ShelleyValidatedTx _txid vtx) =
AlonzoMeasure {
byteSize = Mempool.ByteSize $ txInBlockSize (mkShelleyTx @(ConwayEra c) @p (SL.extractTx vtx))
, exUnits = fromExUnits $ totExUnits (SL.extractTx vtx)
}
txsBlockCapacity ledgerState =
AlonzoMeasure {
byteSize = Mempool.ByteSize $ txsMaxBytes ledgerState
, exUnits = fromExUnits $ pparams ^. ppMaxBlockExUnitsL
}
where
pparams = getPParams $ tickedShelleyLedgerState ledgerState
{-------------------------------------------------------------------------------
WithTop
-------------------------------------------------------------------------------}
-- | Add a unique top element to a lattice.
--
-- TODO This should be relocated to `cardano-base:Data.Measure'.
data WithTop a = NotTop a | Top
deriving (Eq, Generic, Show)
instance Ord a => Ord (WithTop a) where
compare = curry $ \case
(Top , Top ) -> EQ
(Top , _ ) -> GT
(_ , Top ) -> LT
(NotTop l, NotTop r) -> compare l r
instance Measure a => Measure (WithTop a) where
zero = NotTop Measure.zero
plus = curry $ \case
(Top , _ ) -> Top
(_ , Top ) -> Top
(NotTop l, NotTop r) -> NotTop $ Measure.plus l r
min = curry $ \case
(Top , r ) -> r
(l , Top ) -> l
(NotTop l, NotTop r) -> NotTop $ Measure.min l r
max = curry $ \case
(Top , _ ) -> Top
(_ , Top ) -> Top
(NotTop l, NotTop r) -> NotTop $ Measure.max l r
instance Measure a => BoundedMeasure (WithTop a) where
maxBound = Top