-
Notifications
You must be signed in to change notification settings - Fork 155
/
Bbody.hs
238 lines (213 loc) · 7.63 KB
/
Bbody.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
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Cardano.Ledger.Alonzo.Rules.Bbody (
AlonzoBBODY,
AlonzoBbodyPredFailure (..),
AlonzoBbodyEvent (..),
bbodyTransition,
) where
import Cardano.Ledger.Alonzo.Era (AlonzoBBODY)
import Cardano.Ledger.Alonzo.PParams (AlonzoEraPParams, ppMaxBlockExUnitsL)
import Cardano.Ledger.Alonzo.Scripts (ExUnits (..), pointWiseExUnits)
import Cardano.Ledger.Alonzo.Tx (AlonzoTx, totExUnits)
import Cardano.Ledger.Alonzo.TxSeq (AlonzoTxSeq, txSeqTxns)
import Cardano.Ledger.Alonzo.TxWits (AlonzoEraTxWits (..))
import Cardano.Ledger.BHeaderView (BHeaderView (..), isOverlaySlot)
import Cardano.Ledger.BaseTypes (ShelleyBase, epochInfoPure)
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
import Cardano.Ledger.Binary.Coders
import Cardano.Ledger.Block (Block (..))
import Cardano.Ledger.Core
import qualified Cardano.Ledger.Era as Era
import Cardano.Ledger.Keys (DSignable, Hash, coerceKeyRole)
import Cardano.Ledger.Shelley.BlockChain (incrBlocks)
import Cardano.Ledger.Shelley.LedgerState (LedgerState)
import Cardano.Ledger.Shelley.Rules (
BbodyEnv (..),
ShelleyBbodyEvent (..),
ShelleyBbodyPredFailure (..),
ShelleyBbodyState (..),
ShelleyLedgersEnv (..),
)
import Cardano.Ledger.Slot (epochInfoEpoch, epochInfoFirst)
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition (
Embed (..),
STS (..),
TRC (..),
TransitionRule,
judgmentContext,
liftSTS,
trans,
(?!),
)
import Data.Kind (Type)
import Data.Sequence (Seq)
import qualified Data.Sequence.Strict as StrictSeq
import Data.Typeable
import GHC.Generics (Generic)
import Lens.Micro ((^.))
import NoThunks.Class (NoThunks (..))
-- =======================================
-- A new PredicateFailure type
data AlonzoBbodyPredFailure era
= ShelleyInAlonzoBbodyPredFailure (ShelleyBbodyPredFailure era)
| TooManyExUnits
!ExUnits
-- ^ Computed Sum of ExUnits for all plutus scripts
!ExUnits
-- ^ Maximum allowed by protocal parameters
deriving (Generic)
newtype AlonzoBbodyEvent era
= ShelleyInAlonzoEvent (ShelleyBbodyEvent era)
deriving instance
(Era era, Show (PredicateFailure (EraRule "LEDGERS" era))) =>
Show (AlonzoBbodyPredFailure era)
deriving instance
(Era era, Eq (PredicateFailure (EraRule "LEDGERS" era))) =>
Eq (AlonzoBbodyPredFailure era)
deriving anyclass instance
(Era era, NoThunks (PredicateFailure (EraRule "LEDGERS" era))) =>
NoThunks (AlonzoBbodyPredFailure era)
instance
( Typeable era
, EncCBOR (ShelleyBbodyPredFailure era)
) =>
EncCBOR (AlonzoBbodyPredFailure era)
where
encCBOR (ShelleyInAlonzoBbodyPredFailure x) = encode (Sum ShelleyInAlonzoBbodyPredFailure 0 !> To x)
encCBOR (TooManyExUnits x y) = encode (Sum TooManyExUnits 1 !> To x !> To y)
instance
( Typeable era
, DecCBOR (ShelleyBbodyPredFailure era) -- TODO why is there no DecCBOR for (ShelleyBbodyPredFailure era)
) =>
DecCBOR (AlonzoBbodyPredFailure era)
where
decCBOR = decode (Summands "AlonzoBbodyPredFail" dec)
where
dec 0 = SumD ShelleyInAlonzoBbodyPredFailure <! From
dec 1 = SumD TooManyExUnits <! From <! From
dec n = Invalid n
-- ========================================
-- The STS instance
bbodyTransition ::
forall (someBBODY :: Type -> Type) era.
( STS (someBBODY era)
, Signal (someBBODY era) ~ Block (BHeaderView (EraCrypto era)) era
, PredicateFailure (someBBODY era) ~ AlonzoBbodyPredFailure era
, BaseM (someBBODY era) ~ ShelleyBase
, State (someBBODY era) ~ ShelleyBbodyState era
, Environment (someBBODY era) ~ BbodyEnv era
, Embed (EraRule "LEDGERS" era) (someBBODY era)
, Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era
, State (EraRule "LEDGERS" era) ~ LedgerState era
, Signal (EraRule "LEDGERS" era) ~ Seq (Tx era)
, EraSegWits era
, AlonzoEraTxWits era
, Era.TxSeq era ~ AlonzoTxSeq era
, Tx era ~ AlonzoTx era
, AlonzoEraPParams era
) =>
TransitionRule (someBBODY era)
bbodyTransition =
judgmentContext
>>= \( TRC
( BbodyEnv pp account
, BbodyState ls b
, UnserialisedBlock bh txsSeq
)
) -> do
let txs = txSeqTxns txsSeq
actualBodySize = bBodySize (pp ^. ppProtocolVersionL) txsSeq
actualBodyHash = hashTxSeq @era txsSeq
actualBodySize
== fromIntegral (bhviewBSize bh)
?! ShelleyInAlonzoBbodyPredFailure
( WrongBlockBodySizeBBODY actualBodySize (fromIntegral $ bhviewBSize bh)
)
actualBodyHash
== bhviewBHash bh
?! ShelleyInAlonzoBbodyPredFailure
( InvalidBodyHashBBODY @era actualBodyHash (bhviewBHash bh)
)
ls' <-
trans @(EraRule "LEDGERS" era) $
TRC (LedgersEnv (bhviewSlot bh) pp account, ls, StrictSeq.fromStrict txs)
-- Note that this may not actually be a stake pool - it could be a
-- genesis key delegate. However, this would only entail an overhead of
-- 7 counts, and it's easier than differentiating here.
--
-- TODO move this computation inside 'incrBlocks' where it belongs. Here
-- we make an assumption that 'incrBlocks' must enforce, better for it
-- to be done in 'incrBlocks' where we can see that the assumption is
-- enforced.
let hkAsStakePool = coerceKeyRole . bhviewID $ bh
slot = bhviewSlot bh
firstSlotNo <- liftSTS $ do
ei <- asks epochInfoPure
e <- epochInfoEpoch ei slot
epochInfoFirst ei e
{- ∑(tx ∈ txs)(totExunits tx) ≤ maxBlockExUnits pp -}
let txTotal, ppMax :: ExUnits
txTotal = foldMap totExUnits txs
ppMax = pp ^. ppMaxBlockExUnitsL
pointWiseExUnits (<=) txTotal ppMax ?! TooManyExUnits txTotal ppMax
pure $
BbodyState @era
ls'
( incrBlocks
(isOverlaySlot firstSlotNo (pp ^. ppDG) slot)
hkAsStakePool
b
)
instance
( DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody)
, Embed (EraRule "LEDGERS" era) (AlonzoBBODY era)
, Environment (EraRule "LEDGERS" era) ~ ShelleyLedgersEnv era
, State (EraRule "LEDGERS" era) ~ LedgerState era
, Signal (EraRule "LEDGERS" era) ~ Seq (AlonzoTx era)
, AlonzoEraTxWits era
, Tx era ~ AlonzoTx era
, Era.TxSeq era ~ AlonzoTxSeq era
, Tx era ~ AlonzoTx era
, EraSegWits era
, AlonzoEraPParams era
) =>
STS (AlonzoBBODY era)
where
type
State (AlonzoBBODY era) =
ShelleyBbodyState era
type
Signal (AlonzoBBODY era) =
(Block (BHeaderView (EraCrypto era)) era)
type Environment (AlonzoBBODY era) = BbodyEnv era
type BaseM (AlonzoBBODY era) = ShelleyBase
type PredicateFailure (AlonzoBBODY era) = AlonzoBbodyPredFailure era
type Event (AlonzoBBODY era) = AlonzoBbodyEvent era
initialRules = []
transitionRules = [bbodyTransition @AlonzoBBODY]
instance
( Era era
, BaseM ledgers ~ ShelleyBase
, ledgers ~ EraRule "LEDGERS" era
, STS ledgers
, DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody)
, Era era
) =>
Embed ledgers (AlonzoBBODY era)
where
wrapFailed = ShelleyInAlonzoBbodyPredFailure . LedgersFailure
wrapEvent = ShelleyInAlonzoEvent . LedgersEvent