/
Node.hs
378 lines (330 loc) · 14.7 KB
/
Node.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
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wredundant-constraints -Werror=missing-fields #-}
module Ouroboros.Consensus.Node (
-- * Node
NodeKernel (..)
, NodeCallbacks (..)
, NodeParams (..)
, TraceConstraints
, nodeKernel
-- * Auxiliary functions
, tracePrefix
) where
import Control.Monad (void)
import Crypto.Random (ChaChaDRG)
import Data.Functor.Contravariant (contramap)
import Data.Map.Strict (Map)
import Control.Monad.Class.MonadAsync
import Control.Monad.Class.MonadFork (MonadFork)
import Control.Monad.Class.MonadSTM
import Control.Monad.Class.MonadThrow
import Control.Tracer
import Ouroboros.Network.AnchoredFragment (AnchoredFragment (..),
headSlot)
import Ouroboros.Network.Block
import Ouroboros.Network.BlockFetch
import Ouroboros.Network.BlockFetch.State (FetchMode (..))
import qualified Ouroboros.Network.Chain as Chain
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime
import Ouroboros.Consensus.ChainSyncClient
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Extended
import Ouroboros.Consensus.Mempool
import Ouroboros.Consensus.Mempool.TxSeq (TicketNo)
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Util
import Ouroboros.Consensus.Util.Condense
import Ouroboros.Consensus.Util.Orphans ()
import Ouroboros.Consensus.Util.Random
import Ouroboros.Consensus.Util.STM
import Ouroboros.Consensus.Util.ThreadRegistry
import Ouroboros.Storage.ChainDB.API (ChainDB)
import qualified Ouroboros.Storage.ChainDB.API as ChainDB
{-------------------------------------------------------------------------------
Relay node
-------------------------------------------------------------------------------}
-- | Interface against running relay node
data NodeKernel m peer blk = NodeKernel {
-- | The 'ChainDB' of the node
getChainDB :: ChainDB m blk
-- | The node's mempool
, getMempool :: Mempool m blk TicketNo
-- | The node's static configuration
, getNodeConfig :: NodeConfig (BlockProtocol blk)
-- | The fetch client registry, used for the block fetch clients.
, getFetchClientRegistry :: FetchClientRegistry peer (Header blk) blk m
-- | Read the current candidates
, getNodeCandidates :: TVar m (Map peer (TVar m (CandidateState blk)))
}
-- | Monad that we run protocol specific functions in
type ProtocolM blk m = NodeStateT (BlockProtocol blk) (ChaChaT (STM m))
-- | Callbacks required when running the node
data NodeCallbacks m blk = NodeCallbacks {
-- | Produce a block
--
-- The function is passed the contents of the mempool; this is a set of
-- transactions that is guaranteed to be consistent with the ledger state
-- (also provided as an argument) and with each other (when applied in
-- order). In principle /all/ of them could be included in the block (up
-- to maximum block size).
produceBlock :: IsLeader (BlockProtocol blk) -- Proof we are leader
-> ExtLedgerState blk -- Current ledger state
-> SlotNo -- Current slot
-> Point blk -- Previous point
-> BlockNo -- Previous block number
-> [GenTx blk] -- Contents of the mempool
-> ProtocolM blk m blk
-- | Produce a random seed
--
-- We want to be able to use real (crypto strength) random numbers, but
-- obviously have no access to a sytem random number source inside an
-- STM transaction. So we use the system RNG to generate a local DRG,
-- which we then use for this transaction, and /only/ this transaction.
-- The loss of entropy therefore is minimal.
--
-- In IO, can use 'Crypto.Random.drgNew'.
, produceDRG :: m ChaChaDRG
}
-- | Parameters required when initializing a node
data NodeParams m peer blk = NodeParams {
tracer :: Tracer m String
, mempoolTracer :: Tracer m (TraceEventMempool blk)
, decisionTracer :: Tracer m [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]
, fetchClientTracer :: Tracer m (TraceLabelPeer peer (TraceFetchClientState (Header blk)))
, threadRegistry :: ThreadRegistry m
, maxClockSkew :: ClockSkew
, cfg :: NodeConfig (BlockProtocol blk)
, initState :: NodeState (BlockProtocol blk)
, btime :: BlockchainTime m
, chainDB :: ChainDB m blk
, callbacks :: NodeCallbacks m blk
, blockFetchSize :: Header blk -> SizeInBytes
, blockMatchesHeader :: Header blk -> blk -> Bool
}
nodeKernel
:: forall m peer blk.
( MonadAsync m
, MonadFork m
, MonadMask m
, ProtocolLedgerView blk
, Ord peer
, TraceConstraints peer blk
, ApplyTx blk
)
=> NodeParams m peer blk
-> m (NodeKernel m peer blk)
nodeKernel params@NodeParams { threadRegistry, cfg, decisionTracer, fetchClientTracer } = do
st <- initInternalState params
forkBlockProduction st
let IS { blockFetchInterface, fetchClientRegistry, varCandidates,
chainDB, mempool } = st
-- Run the block fetch logic in the background. This will call
-- 'addFetchedBlock' whenever a new block is downloaded.
void $ forkLinked threadRegistry $ blockFetchLogic
decisionTracer
fetchClientTracer
blockFetchInterface
fetchClientRegistry
return NodeKernel {
getChainDB = chainDB
, getMempool = mempool
, getNodeConfig = cfg
, getFetchClientRegistry = fetchClientRegistry
, getNodeCandidates = varCandidates
}
{-------------------------------------------------------------------------------
Internal node components
-------------------------------------------------------------------------------}
-- | Constraints required to trace nodes, block, headers, etc.
type TraceConstraints peer blk =
( Condense peer
, Condense blk
, Condense (ChainHash blk)
, Condense (Header blk)
)
data InternalState m peer blk = IS {
cfg :: NodeConfig (BlockProtocol blk)
, threadRegistry :: ThreadRegistry m
, btime :: BlockchainTime m
, callbacks :: NodeCallbacks m blk
, chainDB :: ChainDB m blk
, blockFetchInterface :: BlockFetchConsensusInterface peer (Header blk) blk m
, fetchClientRegistry :: FetchClientRegistry peer (Header blk) blk m
, varCandidates :: TVar m (Map peer (TVar m (CandidateState blk)))
, varState :: TVar m (NodeState (BlockProtocol blk))
, tracer :: Tracer m String
, mempool :: Mempool m blk TicketNo
}
initInternalState
:: forall m peer blk.
( MonadAsync m
, MonadFork m
, MonadMask m
, ProtocolLedgerView blk
, Ord peer
, TraceConstraints peer blk
, ApplyTx blk
)
=> NodeParams m peer blk
-> m (InternalState m peer blk)
initInternalState NodeParams {..} = do
varCandidates <- atomically $ newTVar mempty
varState <- atomically $ newTVar initState
mempool <- openMempool threadRegistry
chainDB
(ledgerConfigView cfg)
mempoolTracer
fetchClientRegistry <- newFetchClientRegistry
let getCandidates :: STM m (Map peer (AnchoredFragment (Header blk)))
getCandidates = readTVar varCandidates >>=
traverse (fmap candidateChain . readTVar)
blockFetchInterface :: BlockFetchConsensusInterface peer (Header blk) blk m
blockFetchInterface = initBlockFetchConsensusInterface
(tracePrefix "ChainDB" (Nothing :: Maybe peer) tracer)
cfg chainDB getCandidates blockFetchSize blockMatchesHeader btime
return IS {..}
tracePrefix :: Condense peer
=> String
-> Maybe peer
-> Tracer m String
-> Tracer m String
tracePrefix p mbUp tr =
let prefix = p <> maybe "" ((" " <>) . condense) mbUp <> " | "
in contramap (prefix <>) tr
initBlockFetchConsensusInterface
:: forall m peer blk.
( MonadSTM m
, TraceConstraints peer blk
, SupportedBlock blk
)
=> Tracer m String
-> NodeConfig (BlockProtocol blk)
-> ChainDB m blk
-> STM m (Map peer (AnchoredFragment (Header blk)))
-> (Header blk -> SizeInBytes)
-> (Header blk -> blk -> Bool)
-> BlockchainTime m
-> BlockFetchConsensusInterface peer (Header blk) blk m
initBlockFetchConsensusInterface tracer cfg chainDB getCandidates blockFetchSize
blockMatchesHeader btime = BlockFetchConsensusInterface {..}
where
readCandidateChains :: STM m (Map peer (AnchoredFragment (Header blk)))
readCandidateChains = getCandidates
readCurrentChain :: STM m (AnchoredFragment (Header blk))
readCurrentChain = ChainDB.getCurrentChain chainDB
readFetchMode :: STM m FetchMode
readFetchMode = do
curSlot <- getCurrentSlot btime
curChainSlot <- headSlot <$> ChainDB.getCurrentChain chainDB
let slotsBehind = unSlotNo curSlot - unSlotNo curChainSlot
maxBlocksBehind = 5
-- Convert from blocks to slots. This is more or less the @f@
-- parameter, the frequency of blocks. TODO should be 10 for Praos,
-- so make this part of 'OuroborosTag'.
blocksToSlots = 1
return $ if slotsBehind < maxBlocksBehind * blocksToSlots
-- When the current chain is near to "now", use deadline mode, when it
-- is far away, use bulk sync mode.
then FetchModeDeadline
else FetchModeBulkSync
readFetchedBlocks :: STM m (Point blk -> Bool)
readFetchedBlocks = ChainDB.getIsFetched chainDB
addFetchedBlock :: Point blk -> blk -> m ()
addFetchedBlock _pt blk = do
ChainDB.addBlock chainDB blk
traceWith tracer $ "Downloaded block: " <> condense blk
plausibleCandidateChain :: AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Bool
plausibleCandidateChain = preferCandidate cfg
compareCandidateChains :: AnchoredFragment (Header blk)
-> AnchoredFragment (Header blk)
-> Ordering
compareCandidateChains = compareCandidates cfg
forkBlockProduction
:: forall m peer blk.
( MonadAsync m
, ProtocolLedgerView blk
, TraceConstraints peer blk
)
=> InternalState m peer blk -> m ()
forkBlockProduction IS{..} =
onSlotChange btime $ \currentSlot -> do
drg <- produceDRG
mNewBlock <- atomically $ do
varDRG <- newTVar drg
l@ExtLedgerState{..} <- ChainDB.getCurrentLedger chainDB
mIsLeader <- runProtocol varDRG $
checkIsLeader
cfg
currentSlot
(protocolLedgerView cfg ledgerState)
ouroborosChainState
case mIsLeader of
Nothing -> return Nothing
Just proof -> do
(prevPoint, prevNo) <- prevPointAndBlockNo currentSlot <$>
ChainDB.getCurrentChain chainDB
-- In this circumstance, it is required that we call 'syncState'
-- before 'getTxs' within this 'STM' transaction since we need to
-- guarantee that the transactions returned from 'getTxs' are
-- valid with respect to the current ledger state of the
-- 'ChainDB'. Refer to the 'getTxs' documentation for more
-- information.
_ <- pure $ syncState mempool
mempoolSnapshot <- getSnapshot mempool
let txs = map sndOfTriple (getTxs mempoolSnapshot)
newBlock <- runProtocol varDRG $
produceBlock
proof
l
currentSlot
(castPoint prevPoint)
prevNo
txs
return $ Just newBlock
whenJust mNewBlock $ \newBlock -> do
traceWith tracer $
"As leader of slot " <> condense currentSlot <> " I produce: " <>
condense newBlock
ChainDB.addBlock chainDB newBlock
where
NodeCallbacks{..} = callbacks
-- Return the second item in a triple.
sndOfTriple (_, b, _) = b
-- Return the point and block number of the most recent block in the
-- current chain with a slot < the given slot. These will either
-- correspond to the header at the tip of the current chain or, in case
-- another node was also elected leader and managed to produce a block
-- before us, the header right before the one at the tip of the chain.
prevPointAndBlockNo :: SlotNo
-> AnchoredFragment (Header blk)
-> (Point blk, BlockNo)
prevPointAndBlockNo slot c = case c of
Empty _ -> (Chain.genesisPoint, Chain.genesisBlockNo)
c' :> hdr -> case blockSlot hdr `compare` slot of
LT -> (headerPoint hdr, blockNo hdr)
-- The block at the tip of our chain has a slot that lies in the
-- future.
GT -> error "prevPointAndBlockNo: block in future"
-- The block at the tip has the same slot as the block we're going
-- to produce (@slot@), so look at the block before it.
EQ | _ :> hdr' <- c'
-> (headerPoint hdr', blockNo hdr')
| otherwise
-- If there is no block before it, so use genesis.
-> (Chain.genesisPoint, Chain.genesisBlockNo)
runProtocol :: TVar m ChaChaDRG -> ProtocolM blk m a -> STM m a
runProtocol varDRG = simOuroborosStateT varState
$ simChaChaT varDRG
$ id