-
Notifications
You must be signed in to change notification settings - Fork 155
/
Validation.hs
206 lines (186 loc) · 6.12 KB
/
Validation.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
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Interface to the block validation and chain extension logic in the Shelley
-- API.
module Shelley.Spec.Ledger.API.Validation
( ApplyBlock (..),
TickTransitionError (..),
BlockTransitionError (..),
chainChecks,
)
where
import Cardano.Ledger.Core (AnnotatedData, ChainData, SerialisableData)
import Cardano.Ledger.Era (Crypto, Era)
import Cardano.Ledger.Shelley (ShelleyBased, ShelleyEra)
import Control.Arrow (left, right)
import Control.Monad.Except
import Control.Monad.Trans.Reader (runReader)
import Control.State.Transition.Extended
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Shelley.Spec.Ledger.API.Protocol (PraosCrypto)
import Shelley.Spec.Ledger.BaseTypes (Globals (..))
import Shelley.Spec.Ledger.BlockChain
import Shelley.Spec.Ledger.LedgerState (NewEpochState)
import qualified Shelley.Spec.Ledger.LedgerState as LedgerState
import qualified Shelley.Spec.Ledger.STS.Bbody as STS
import qualified Shelley.Spec.Ledger.STS.Chain as STS
import qualified Shelley.Spec.Ledger.STS.Tick as STS
import Shelley.Spec.Ledger.Slot (SlotNo)
{-------------------------------------------------------------------------------
Block validation API
-------------------------------------------------------------------------------}
class
( ChainData (Block era),
AnnotatedData (Block era),
ChainData (BHeader (Crypto era)),
AnnotatedData (BHeader (Crypto era)),
ChainData (NewEpochState era),
SerialisableData (NewEpochState era),
ChainData (BlockTransitionError era),
ChainData (STS.PredicateFailure (STS.CHAIN era))
) =>
ApplyBlock era
where
-- | Apply the header level ledger transition.
--
-- This handles checks and updates that happen on a slot tick, as well as a
-- few header level checks, such as size constraints.
applyTick ::
Globals ->
NewEpochState era ->
SlotNo ->
NewEpochState era
default applyTick ::
ShelleyBased era =>
Globals ->
NewEpochState era ->
SlotNo ->
NewEpochState era
applyTick globals state hdr =
(either err id) . flip runReader globals
. applySTS @(STS.TICK era)
$ TRC ((), state, hdr)
where
err :: Show a => a -> b
err msg = error $ "Panic! applyTick failed: " <> (show msg)
-- | Apply the block level ledger transition.
applyBlock ::
MonadError (BlockTransitionError era) m =>
Globals ->
NewEpochState era ->
Block era ->
m (NewEpochState era)
default applyBlock ::
( STS (STS.BBODY era),
MonadError (BlockTransitionError era) m
) =>
Globals ->
NewEpochState era ->
Block era ->
m (NewEpochState era)
applyBlock globals state blk =
liftEither
. right (updateNewEpochState state)
. left (BlockTransitionError . join)
$ res
where
res =
flip runReader globals . applySTS @(STS.BBODY era) $
TRC (mkBbodyEnv state, bbs, blk)
bbs =
STS.BbodyState
(LedgerState.esLState $ LedgerState.nesEs state)
(LedgerState.nesBcur state)
-- | Re-apply a ledger block to the same state it has been applied to before.
--
-- This function does no validation of whether the block applies successfully;
-- the caller implicitly guarantees that they have previously called
-- 'applyBlockTransition' on the same block and that this was successful.
reapplyBlock ::
Globals ->
NewEpochState era ->
Block era ->
NewEpochState era
default reapplyBlock ::
STS (STS.BBODY era) =>
Globals ->
NewEpochState era ->
Block era ->
NewEpochState era
reapplyBlock globals state blk =
updateNewEpochState state res
where
res =
flip runReader globals . reapplySTS @(STS.BBODY era) $
TRC (mkBbodyEnv state, bbs, blk)
bbs =
STS.BbodyState
(LedgerState.esLState $ LedgerState.nesEs state)
(LedgerState.nesBcur state)
instance PraosCrypto crypto => ApplyBlock (ShelleyEra crypto)
{-------------------------------------------------------------------------------
CHAIN Transition checks
-------------------------------------------------------------------------------}
chainChecks ::
forall era m.
( Era era,
MonadError (STS.PredicateFailure (STS.CHAIN era)) m
) =>
Globals ->
STS.ChainChecksData ->
BHeader (Crypto era) ->
m ()
chainChecks globals ccd bh = STS.chainChecks (maxMajorPV globals) ccd bh
{-------------------------------------------------------------------------------
Applying blocks
-------------------------------------------------------------------------------}
mkBbodyEnv ::
NewEpochState era ->
STS.BbodyEnv era
mkBbodyEnv
LedgerState.NewEpochState
{ LedgerState.nesEs
} =
STS.BbodyEnv
{ STS.bbodyPp = LedgerState.esPp nesEs,
STS.bbodyAccount = LedgerState.esAccountState nesEs
}
updateNewEpochState ::
NewEpochState era ->
STS.BbodyState era ->
NewEpochState era
updateNewEpochState ss (STS.BbodyState ls bcur) =
LedgerState.updateNES ss bcur ls
newtype TickTransitionError era
= TickTransitionError [STS.PredicateFailure (STS.TICK era)]
deriving (Generic)
instance
(NoThunks (STS.PredicateFailure (STS.TICK era))) =>
NoThunks (TickTransitionError era)
deriving stock instance
(Eq (STS.PredicateFailure (STS.TICK era))) =>
Eq (TickTransitionError era)
deriving stock instance
(Show (STS.PredicateFailure (STS.TICK era))) =>
Show (TickTransitionError era)
newtype BlockTransitionError era
= BlockTransitionError [STS.PredicateFailure (STS.BBODY era)]
deriving (Generic)
deriving stock instance
(Eq (STS.PredicateFailure (STS.BBODY era))) =>
Eq (BlockTransitionError era)
deriving stock instance
(Show (STS.PredicateFailure (STS.BBODY era))) =>
Show (BlockTransitionError era)
instance
(NoThunks (STS.PredicateFailure (STS.BBODY era))) =>
NoThunks (BlockTransitionError era)