-
Notifications
You must be signed in to change notification settings - Fork 154
/
Validation.hs
168 lines (154 loc) · 5.23 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
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
-- | Interface to the block validation and chain extension logic in the Shelley
-- API.
module Shelley.Spec.Ledger.API.Validation
( ShelleyState,
TickTransitionError (..),
BlockTransitionError (..),
chainChecks,
applyTickTransition,
applyBlockTransition,
reapplyBlockTransition,
)
where
import Cardano.Prelude (NoUnexpectedThunks (..))
import Control.Arrow (left, right)
import Control.Monad.Except
import Control.Monad.Trans.Reader (runReader)
import Control.State.Transition.Extended (TRC (..), applySTS, reapplySTS)
import Data.Either (fromRight)
import GHC.Generics (Generic)
import Shelley.Spec.Ledger.BaseTypes (Globals (..))
import Shelley.Spec.Ledger.BlockChain
import Shelley.Spec.Ledger.Core (Relation (..))
import Shelley.Spec.Ledger.Crypto
import Shelley.Spec.Ledger.Keys
import qualified Shelley.Spec.Ledger.LedgerState as LedgerState
import Shelley.Spec.Ledger.PParams (PParams)
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)
import qualified Shelley.Spec.Ledger.TxData as Tx
-- | Type alias for the state updated by TICK and BBODY rules
type ShelleyState = LedgerState.NewEpochState
{-------------------------------------------------------------------------------
CHAIN Transition checks
-------------------------------------------------------------------------------}
chainChecks ::
forall crypto m.
(Crypto crypto, MonadError (STS.PredicateFailure (STS.CHAIN crypto)) m) =>
Globals ->
PParams ->
BHeader crypto ->
m ()
chainChecks globals pp bh = STS.chainChecks (maxMajorPV globals) pp bh
{-------------------------------------------------------------------------------
Applying blocks
-------------------------------------------------------------------------------}
mkTickEnv ::
ShelleyState crypto ->
STS.TickEnv crypto
mkTickEnv = STS.TickEnv . LedgerState.getGKeys
mkBbodyEnv ::
ShelleyState crypto ->
STS.BbodyEnv
mkBbodyEnv
LedgerState.NewEpochState
{ LedgerState.nesOsched,
LedgerState.nesEs
} =
STS.BbodyEnv
{ STS.bbodySlots = dom nesOsched,
STS.bbodyPp = LedgerState.esPp nesEs,
STS.bbodyAccount = LedgerState.esAccountState nesEs
}
newtype TickTransitionError crypto
= TickTransitionError [STS.PredicateFailure (STS.TICK crypto)]
deriving (Eq, Show, Generic)
instance NoUnexpectedThunks (TickTransitionError crypto)
-- | 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.
applyTickTransition ::
forall crypto.
(Crypto crypto) =>
Globals ->
ShelleyState crypto ->
SlotNo ->
ShelleyState crypto
applyTickTransition globals state hdr =
fromRight err . flip runReader globals
. applySTS @(STS.TICK crypto)
$ TRC (mkTickEnv state, state, hdr)
where
err = error "Panic! applyHeaderTransition failed."
newtype BlockTransitionError crypto
= BlockTransitionError [STS.PredicateFailure (STS.BBODY crypto)]
deriving (Eq, Generic, Show)
instance (Crypto crypto) => NoUnexpectedThunks (BlockTransitionError crypto)
-- | Apply the block level ledger transition.
applyBlockTransition ::
forall crypto m.
( Crypto crypto,
MonadError (BlockTransitionError crypto) m,
DSignable crypto (Hash crypto (Tx.TxBody crypto))
) =>
Globals ->
ShelleyState crypto ->
Block crypto ->
m (ShelleyState crypto)
applyBlockTransition globals state blk =
liftEither
. right (updateShelleyState state)
. left (BlockTransitionError . join)
$ res
where
res =
flip runReader globals . applySTS @(STS.BBODY crypto) $
TRC (mkBbodyEnv state, bbs, blk)
updateShelleyState ::
ShelleyState crypto ->
STS.BbodyState crypto ->
ShelleyState crypto
updateShelleyState ss (STS.BbodyState ls bcur) =
LedgerState.updateNES ss bcur ls
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.
reapplyBlockTransition ::
forall crypto.
( Crypto crypto,
DSignable crypto (Hash crypto (Tx.TxBody crypto))
) =>
Globals ->
ShelleyState crypto ->
Block crypto ->
ShelleyState crypto
reapplyBlockTransition globals state blk =
updateShelleyState state res
where
res =
flip runReader globals . reapplySTS @(STS.BBODY crypto) $
TRC (mkBbodyEnv state, bbs, blk)
updateShelleyState ::
ShelleyState crypto ->
STS.BbodyState crypto ->
ShelleyState crypto
updateShelleyState ss (STS.BbodyState ls bcur) =
LedgerState.updateNES ss bcur ls
bbs =
STS.BbodyState
(LedgerState.esLState $ LedgerState.nesEs state)
(LedgerState.nesBcur state)