/
Shelley.hs
374 lines (322 loc) · 13.2 KB
/
Shelley.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
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
module Test.ThreadNet.Shelley (tests) where
import Control.Monad (replicateM)
import qualified Data.Map.Strict as Map
import Data.Word (Word64)
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
import Cardano.Crypto.Hash (ShortHash)
import Cardano.Slotting.EpochInfo (fixedEpochInfo)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config.SecurityParam
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool (extractTxs)
import Ouroboros.Consensus.Node.NetworkProtocolVersion
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.NodeId
import Test.ThreadNet.General
import Test.ThreadNet.Infra.Shelley
import Test.ThreadNet.Network (TestNodeInitialization (..),
nodeOutputFinalLedger)
import qualified Cardano.Ledger.BaseTypes as SL (UnitInterval,
mkNonceFromNumber, unboundRational)
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Protocol.TPraos.OCert as SL
import Test.Util.HardFork.Future (singleEraFuture)
import Test.Util.Orphans.Arbitrary ()
import Test.Util.Slots (NumSlots (..))
import Test.Util.TestEnv
import Ouroboros.Consensus.Shelley.Eras (EraCrypto)
import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock)
import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley
import Ouroboros.Consensus.Shelley.Node
import Ouroboros.Consensus.Protocol.TPraos (TPraos)
import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
import Test.Consensus.Shelley.MockCrypto (MockCrypto, MockShelley)
import Test.ThreadNet.TxGen.Shelley
import Test.ThreadNet.Util.NodeJoinPlan (trivialNodeJoinPlan)
import Test.ThreadNet.Util.NodeRestarts (noRestarts)
import Test.ThreadNet.Util.NodeToNodeVersion (genVersion)
import Test.ThreadNet.Util.Seed (runGen)
type Era = MockShelley ShortHash
type Proto = TPraos (MockCrypto ShortHash)
data TestSetup = TestSetup
{ setupD :: DecentralizationParam
, setupD2 :: DecentralizationParam
-- ^ scheduled value
--
-- If not equal to 'setupD', every node immediately (ie slot 0) issues a
-- protocol update transaction that will change the @d@ protocol parameter
-- accordingly.
, setupInitialNonce :: SL.Nonce
-- ^ the initial Shelley 'SL.ticknStateEpochNonce'
--
-- This test varies it too ensure it explores different leader schedules.
, setupK :: SecurityParam
, setupTestConfig :: TestConfig
, setupVersion :: (NodeToNodeVersion, BlockNodeToNodeVersion (ShelleyBlock Proto Era))
}
deriving (Show)
minK :: Word64
minK = 5 -- Less than this increases risk of CP violations
maxK :: Word64
maxK = 10 -- More than this wastes execution time
activeSlotCoeff :: Rational
activeSlotCoeff = 0.5 -- TODO this is high
instance Arbitrary TestSetup where
arbitrary = do
setupD <- arbitrary
setupD2 <- arbitrary
setupInitialNonce <- frequency
[ (1, pure SL.NeutralNonce)
, (9, SL.mkNonceFromNumber <$> arbitrary)
]
setupK <- SecurityParam <$> choose (minK, maxK)
setupTestConfig <- arbitrary
setupVersion <- genVersion (Proxy @(ShelleyBlock Proto Era))
pure TestSetup
{ setupD
, setupD2
, setupInitialNonce
, setupK
, setupTestConfig
, setupVersion
}
-- TODO shrink
-- | We run for more slots at night.
newtype NightlyTestSetup = NightlyTestSetup TestSetup
deriving (Show)
instance Arbitrary NightlyTestSetup where
shrink (NightlyTestSetup setup) = NightlyTestSetup <$> shrink setup
arbitrary = do
setup <- arbitrary
-- This caused 100 tests to have an expected run time of half an hour on
-- a Buildkite machine. Note that the Buildkite CI infrastructure is now
-- deprecated in favour of self-hosted Hydra instances.
--
-- 100 extended tests had an average run time of 4643 seconds
-- 100 unextended tests had an average of 689 seconds
--
-- 3/4*689 + 1/4*4643 seconds =~= 28 minutes.
moreEpochs <- frequency [(3, pure False), (1, pure True)]
NightlyTestSetup <$> if not moreEpochs then pure setup else do
let TestSetup
{ setupK
, setupTestConfig
} = setup
TestConfig
{ numSlots
} = setupTestConfig
NumSlots t = numSlots
-- run for multiple epochs
factor <- choose (1, 2)
let t' = t + factor * unEpochSize (mkEpochSize setupK activeSlotCoeff)
pure setup
{ setupTestConfig = setupTestConfig
{ numSlots = NumSlots t'
}
}
-- | Run relatively fewer tests
--
-- These tests are slow, so we settle for running fewer of them in this test
-- suite since it is invoked frequently (eg CI for each push).
fifthTestCount :: QuickCheckTests -> QuickCheckTests
fifthTestCount (QuickCheckTests n) = QuickCheckTests $
if 0 == n then 0 else
max 1 $ n `div` 5
tests :: TestTree
tests = localOption (QuickCheckTests 100) $ testGroup "Shelley ThreadNet"
[ let name = "simple convergence" in
askTestEnv $ \case
Nightly -> testProperty name $ \(NightlyTestSetup setup) ->
prop_simple_real_tpraos_convergence setup
_ -> adjustOption fifthTestCount $ testProperty name prop_simple_real_tpraos_convergence
]
prop_simple_real_tpraos_convergence :: TestSetup -> Property
prop_simple_real_tpraos_convergence TestSetup
{ setupD
, setupD2
, setupInitialNonce
, setupK
, setupTestConfig
, setupVersion
} =
countertabulate "Epoch number of last slot"
( show $
if 0 >= unNumSlots numSlots then 0 else
(unNumSlots numSlots - 1) `div` unEpochSize epochSize
) $
countertabulate "Updating d"
( if not dShouldUpdate then "No" else
"Yes, " <> show (compare setupD setupD2)
) $
counterexample (show setupK) $
prop_general PropGeneralArgs
{ pgaBlockProperty = const $ property True
, pgaCountTxs = fromIntegral . length . extractTxs
, pgaExpectedCannotForge = noExpectedCannotForges
, pgaFirstBlockNo = 0
, pgaFixedMaxForkLength = Nothing
, pgaFixedSchedule = Nothing
, pgaSecurityParam = setupK
, pgaTestConfig = setupTestConfig
, pgaTestConfigB = testConfigB
}
testOutput .&&.
prop_checkFinalD
where
countertabulate :: String -> String -> Property -> Property
countertabulate lbl s =
tabulate lbl [s] . counterexample (lbl <> ": " <> s)
TestConfig
{ initSeed
, numCoreNodes
, numSlots
} = setupTestConfig
testConfigB :: TestConfigB (ShelleyBlock Proto Era)
testConfigB = TestConfigB
{ forgeEbbEnv = Nothing
, future = singleEraFuture tpraosSlotLength epochSize
, messageDelay = noCalcMessageDelay
, nodeJoinPlan = trivialNodeJoinPlan numCoreNodes
, nodeRestarts = noRestarts
, txGenExtra = ShelleyTxGenExtra
{ stgeGenEnv = mkGenEnv inclPPUs coreNodes
, stgeStartAt =
SlotNo $ if includingDUpdateTx then 1 else 0
-- We don't generate any transactions before the transaction
-- carrying the proposal because they might consume its inputs
-- before it does, thereby rendering it invalid.
}
, version = setupVersion
}
inclPPUs :: WhetherToGeneratePPUs
inclPPUs =
-- We don't generate any other updates, since doing so might
-- accidentally supplant the bespoke update that these tests are
-- expecting.
--
-- The transaction this test introduces causes all nodes to propose the
-- same parameter update. It'd technically be OK if some nodes then
-- changed their proposal to a different update, as long as at least
-- @Quorum@-many nodes were still proposing this test's original update
-- as of the epoch boundary. However, we keep the test simple and just
-- avoid introducing any other proposals.
if includingDUpdateTx then DoNotGeneratePPUs else DoGeneratePPUs
-- The slot immediately after the end of this test.
sentinel :: SlotNo
sentinel = SlotNo $ unNumSlots numSlots
-- We don't create the update proposal etc unless @d@ would change.
includingDUpdateTx :: Bool
includingDUpdateTx = setupD /= setupD2
-- The ledger state should have an updated @d@ as of this slot.
dUpdatedAsOf :: SlotNo
dUpdatedAsOf = SlotNo $ unEpochSize epochSize
-- Whether we expect @d@ to be updated during this test
dShouldUpdate :: Bool
dShouldUpdate = includingDUpdateTx && sentinel >= dUpdatedAsOf
testOutput =
runTestNetwork setupTestConfig testConfigB TestConfigMB
{ nodeInfo = \(CoreNodeId nid) ->
TestNodeInitialization
{ tniProtocolInfo =
mkProtocolShelley
genesisConfig
setupInitialNonce
nextProtVer
(coreNodes !! fromIntegral nid)
, tniCrucialTxs =
if not includingDUpdateTx then [] else
mkSetDecentralizationParamTxs
coreNodes
nextProtVer
sentinel -- Does not expire during test
setupD2
}
, mkRekeyM = Nothing
}
initialKESPeriod :: SL.KESPeriod
initialKESPeriod = SL.KESPeriod 0
coreNodes :: [CoreNode (EraCrypto Era)]
coreNodes = runGen initSeed $
replicateM (fromIntegral n) $
genCoreNode initialKESPeriod
where
NumCoreNodes n = numCoreNodes
maxLovelaceSupply :: Word64
maxLovelaceSupply =
fromIntegral (length coreNodes) * initialLovelacePerCoreNode
genesisConfig :: ShelleyGenesis Era
genesisConfig =
mkGenesisConfig
genesisProtVer
setupK
activeSlotCoeff
setupD
maxLovelaceSupply
tpraosSlotLength
(mkKesConfig (Proxy @(EraCrypto Era)) numSlots)
coreNodes
epochSize :: EpochSize
epochSize = sgEpochLength genesisConfig
genesisProtVer :: SL.ProtVer
genesisProtVer = SL.ProtVer 0 0
-- Which protocol version to endorse
nextProtVer :: SL.ProtVer
nextProtVer = incrementMinorProtVer genesisProtVer
-- Does the final ledger state have the expected @d@ value when ticked over
-- to the 'sentinel' slot?
prop_checkFinalD :: Property
prop_checkFinalD =
conjoin $
[ let ls =
-- Handle the corner case where the test has enough scheduled
-- slots to reach the epoch transition but the last several
-- slots end up empty.
Shelley.tickedShelleyLedgerState $
applyChainTick ledgerConfig sentinel lsUnticked
msg =
"The ticked final ledger state of " <> show nid <>
" has an unexpected value for the d protocol parameter."
-- The actual final value of @d@
actual :: SL.UnitInterval
actual = SL._d $ SL.esPp $ SL.nesEs ls
-- The expected final value of @d@
--
-- NOTE: Not applicable if 'dWasFreeToVary'.
expected :: DecentralizationParam
expected = if dShouldUpdate then setupD2 else setupD
in
counterexample ("unticked " <> show lsUnticked) $
counterexample ("ticked " <> show ls) $
counterexample ("(d,d2) = " <> show (setupD, setupD2)) $
counterexample
( "(dUpdatedAsOf, dShouldUpdate) = " <>
show (dUpdatedAsOf, dShouldUpdate)
) $
counterexample msg $
dWasFreeToVary .||.
SL.unboundRational actual ===
decentralizationParamToRational expected
| (nid, lsUnticked) <- finalLedgers
]
where
-- If the test setup does not introduce a PPU then the normal Shelley
-- generator might do so, and so we will not know what d to expect at
-- the end.
dWasFreeToVary :: Bool
dWasFreeToVary = case inclPPUs of
DoGeneratePPUs -> True
DoNotGeneratePPUs -> False
finalLedgers :: [(NodeId, LedgerState (ShelleyBlock Proto Era) Canonical)]
finalLedgers =
Map.toList $ nodeOutputFinalLedger <$> testOutputNodes testOutput
ledgerConfig :: LedgerConfig (ShelleyBlock Proto Era)
ledgerConfig = Shelley.mkShelleyLedgerConfig
genesisConfig
() -- trivial translation context
(fixedEpochInfo epochSize tpraosSlotLength)
(MaxMajorProtVer 1000) -- TODO