/
Abstract.hs
212 lines (187 loc) · 8.21 KB
/
Abstract.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
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
-- | Interface to the ledger layer
module Ouroboros.Consensus.Ledger.Abstract (
-- * Interaction with the ledger layer
UpdateLedger(..)
, TickedLedgerState(..)
, ledgerTipHash
, ledgerTipSlot
, BlockProtocol
, ProtocolLedgerView(..)
, AnachronyFailure(..)
, QueryLedger(..)
, ShowQuery(..)
) where
import Control.Monad.Except
import Data.Type.Equality ((:~:))
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import Cardano.Prelude (NoUnexpectedThunks)
import Ouroboros.Network.Block (ChainHash, HasHeader, Point, SlotNo,
pointHash, pointSlot)
import Ouroboros.Network.Point (WithOrigin)
import Ouroboros.Network.Protocol.LocalStateQuery.Type
(ShowQuery (..))
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Protocol.Abstract
{-------------------------------------------------------------------------------
Interaction with the ledger layer
-------------------------------------------------------------------------------}
-- | Interaction with the ledger layer
class ( HasHeader blk
, HasHeader (Header blk)
, Show (LedgerState blk)
, Show (LedgerError blk)
, Eq (LedgerState blk)
, Eq (LedgerError blk)
, NoUnexpectedThunks (LedgerState blk)
, NoUnexpectedThunks (LedgerError blk)
) => UpdateLedger blk where
data family LedgerState blk :: *
type family LedgerError blk :: *
-- | Static environment required for the ledger
data family LedgerConfig blk :: *
-- | Apply "slot based" state transformations
--
-- When a block is applied to the ledger state, a number of things happen
-- purely based on the slot number of that block. For example:
--
-- * In Byron, scheduled updates are applied, and the update system state is
-- updated.
-- * In Shelley, delegation state is updated (on epoch boundaries).
--
-- The consensus layer must be able to apply such a "chain tick" function,
-- primarily when validating transactions in the mempool (which, conceptually,
-- live in "some block in the future") or when extracting valid transactions
-- from the mempool to insert into a new block to be produced.
--
-- This is not allowed to throw any errors. After all, if this could fail,
-- it would mean a /previous/ block set up the ledger state in such a way
-- that as soon as a certain slot was reached, /any/ block would be invalid.
--
-- PRECONDITION: The slot number must be strictly greater than the slot at
-- the tip of the ledger.
applyChainTick :: LedgerConfig blk
-> SlotNo
-> LedgerState blk
-> TickedLedgerState blk
-- | Apply a block to the ledger state.
--
-- This should apply the /entire/ block (i.e., including 'applyChainTick').
applyLedgerBlock :: LedgerConfig blk
-> blk
-> LedgerState blk
-> Except (LedgerError blk) (LedgerState blk)
-- | Re-apply a block to the very same ledger state it was applied in before.
--
-- Since a block can only be applied to a single, specific, ledger state,
-- if we apply a previously applied block again it will be applied in the
-- very same ledger state, and therefore can't possibly fail.
--
-- It is worth noting that since we already know that the block is valid in
-- the provided ledger state, the ledger layer should not perform /any/
-- validation checks.
reapplyLedgerBlock :: HasCallStack
=> LedgerConfig blk
-> blk
-> LedgerState blk
-> LedgerState blk
-- | Point of the most recently applied block
--
-- Should be 'genesisPoint' when no blocks have been applied yet
ledgerTipPoint :: LedgerState blk -> Point blk
ledgerTipHash :: UpdateLedger blk => LedgerState blk -> ChainHash blk
ledgerTipHash = pointHash . ledgerTipPoint
ledgerTipSlot :: UpdateLedger blk => LedgerState blk -> WithOrigin SlotNo
ledgerTipSlot = pointSlot . ledgerTipPoint
-- | Ledger state with the chain tick function already applied
--
-- 'applyChainTick' is intended to mark the passage of time, without changing
-- the tip of the underlying ledger (i.e., no blocks have been applied).
data TickedLedgerState blk = TickedLedgerState {
-- | The slot number supplied to 'applyChainTick'
tickedSlotNo :: !SlotNo
-- | The underlying ledger state
--
-- NOTE: 'applyChainTick' should /not/ change the tip of the underlying
-- ledger state, which should still refer to the most recent applied
-- /block/. In other words, we should have
--
-- > ledgerTipPoint (tickedLedgerState (applyChainTick cfg slot st)
-- > == ledgerTipPoint st
, tickedLedgerState :: !(LedgerState blk)
}
deriving (Generic)
deriving instance NoUnexpectedThunks (LedgerState blk)
=> NoUnexpectedThunks (TickedLedgerState blk)
-- | Link protocol to ledger
class (SupportedBlock blk, UpdateLedger blk) => ProtocolLedgerView blk where
-- | Extract the ledger environment from the node config
ledgerConfigView :: NodeConfig (BlockProtocol blk)
-> LedgerConfig blk
-- | Extract ledger view from the ledger state
protocolLedgerView :: NodeConfig (BlockProtocol blk)
-> LedgerState blk
-> LedgerView (BlockProtocol blk)
-- | Get a ledger view for a specific slot
--
-- Suppose @k = 4@, i.e., we can roll back 4 blocks
--
-- > /-----------\
-- > | ^
-- > v |
-- > --*--*--*--*--*--*--*--
-- > | A B
-- > |
-- > \- A'
--
-- In other words, this means that we can roll back from point B to point A,
-- and then roll forward to any block on any fork from A. Note that we can
-- /not/ roll back to any siblings of A (such as A'), as that would require
-- us to roll back at least @k + 1@ blocks, which we can't (by definition).
--
-- Given a ledger state at point B, we should be able to verify any of the
-- headers (corresponding to the blocks) at point A or any of its successors
-- on any fork, up to some maximum distance from A. This distance can be
-- determined by the ledger, though must be at least @k@: we must be able to
-- validate any of these past headers, since otherwise we would not be able to
-- switch to a fork. It is not essential that the maximum distance extends
-- into the future (@> k@), though it is helpful: it means that in the chain
-- sync client we can download and validate headers even if they don't fit
-- directly onto the tip of our chain.
--
-- The anachronistic ledger state at point B is precisely the ledger state
-- that can be used to validate this set of headers.
--
-- Invariant: when calling this function with slot @s@ yields a
-- 'SlotBounded' @sb@, then @'atSlot' sb@ yields a 'Just'.
anachronisticProtocolLedgerView
:: NodeConfig (BlockProtocol blk)
-> LedgerState blk
-> WithOrigin SlotNo -- ^ Slot for which you would like a ledger view
-> Either AnachronyFailure (LedgerView (BlockProtocol blk))
-- | See 'anachronisticProtocolLedgerView'.
data AnachronyFailure
= TooFarAhead
| TooFarBehind
deriving (Eq,Show)
-- | Query the ledger state.
--
-- Used by the LocalStateQuery protocol to allow clients to query the ledger
-- state.
class (UpdateLedger blk, ShowQuery (Query blk)) => QueryLedger blk where
-- | Different queries supported by the ledger, indexed by the result type.
data family Query blk :: * -> *
-- | Answer the given query about the ledger state.
answerQuery :: Query blk result -> LedgerState blk -> result
-- | Generalisation of value-level equality of two queries.
eqQuery :: Query blk result1 -> Query blk result2
-> Maybe (result1 :~: result2)