-
Notifications
You must be signed in to change notification settings - Fork 86
/
Mock.hs
175 lines (153 loc) · 5.97 KB
/
Mock.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
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Ouroboros.Consensus.BlockchainTime.Mock (
-- * Fixed time
fixedBlockchainTime
-- * Settable time
, settableBlockchainTime
-- * Testing time
, NumSlots(..)
, TestClock(..)
, TestBlockchainTime(..)
, newTestBlockchainTime
, cloneTestBlockchainTime
, countSlotLengthChanges
) where
import Control.Monad
import Data.Word
import GHC.Generics (Generic)
import GHC.Stack
import Cardano.Prelude (NoUnexpectedThunks)
import Ouroboros.Network.Block (SlotNo (..))
import Ouroboros.Consensus.BlockchainTime
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Consensus.Util.ResourceRegistry
import Ouroboros.Consensus.Util.STM
{-------------------------------------------------------------------------------
Fixed time
-------------------------------------------------------------------------------}
-- | A 'BlockchainTime' that is fixed to the given slot.
--
-- 'onSlotChange_' does nothing.
fixedBlockchainTime :: MonadSTM m => SlotNo -> BlockchainTime m
fixedBlockchainTime slot = BlockchainTime {
getCurrentSlot = return slot
, onSlotChange_ = const (return (return ()))
}
{-------------------------------------------------------------------------------
Settable time
-------------------------------------------------------------------------------}
-- | The current slot can be changed by modifying the given 'StrictTVar'.
--
-- 'onSlotChange_' is not implemented and will return an 'error'.
settableBlockchainTime :: MonadSTM m => StrictTVar m SlotNo -> BlockchainTime m
settableBlockchainTime varCurSlot = BlockchainTime {
getCurrentSlot = readTVar varCurSlot
, onSlotChange_ = error "unimplemented onSlotChange_"
}
{-------------------------------------------------------------------------------
Testing time
-------------------------------------------------------------------------------}
-- | Number of slots
newtype NumSlots = NumSlots Word64
deriving (Show)
-- | The current time during a test run.
data TestClock =
Initializing
-- ^ This phase has a non-zero but negligible duration.
| Running !SlotNo
deriving (Eq, Generic, NoUnexpectedThunks)
data TestBlockchainTime m = TestBlockchainTime
{ testBlockchainTime :: BlockchainTime m
, testBlockchainTimeDone :: m ()
-- ^ Blocks until the end of the final requested slot.
}
-- | Construct new blockchain time that ticks at the specified slot duration
--
-- NOTE: This is just one way to construct time. We can of course also connect
-- this to the real time (if we are in IO), or indeed to a manual tick
-- (in a demo).
--
-- NOTE: The number of slots is only there to make sure we terminate the
-- thread (otherwise the system will keep waiting).
--
-- NOTE: Any code not passed to 'onSlotChange' may start running \"before\" the
-- first slot @SlotNo 0@, i.e. during 'Initializing'. This is likely only
-- appropriate for initialization code etc. In contrast, the argument to
-- 'onSlotChange' is blocked at least until @SlotNo 0@ begins.
newTestBlockchainTime
:: forall m. (IOLike m, HasCallStack)
=> ResourceRegistry m
-> NumSlots -- ^ Number of slots
-> SlotLengths -- ^ Slot duration
-> m (TestBlockchainTime m)
newTestBlockchainTime registry (NumSlots numSlots) slotLens = do
slotVar <- newTVarM Initializing
doneVar <- newEmptyMVar ()
void $ forkLinkedThread registry $ loop slotVar doneVar
let get :: STM m SlotNo
get = blockUntilJust $
(\case
Initializing -> Nothing
Running slot -> Just slot)
<$> readTVar slotVar
btime :: BlockchainTime m
btime = BlockchainTime {
getCurrentSlot = get
, onSlotChange_ = fmap cancelThread .
onEachChange registry Running (Just Initializing) get
}
return $ TestBlockchainTime
{ testBlockchainTime = btime
, testBlockchainTimeDone = readMVar doneVar
}
where
loop :: StrictTVar m TestClock -> StrictMVar m () -> m ()
loop slotVar doneVar = go slotLens numSlots
where
-- count off each requested slot
go :: SlotLengths -> Word64 -> m ()
go _ 0 = putMVar doneVar () -- signal the end of the final slot
go ls n = do
atomically $ modifyTVar slotVar $ Running . \case
Initializing -> SlotNo 0
Running slot -> succ slot
let (SlotLength delay, ls') = tickSlotLengths ls
threadDelay (nominalDelay delay)
go ls' (n - 1)
-- | Create a synchronized clone that uses a different 'ResourceRegistry'
cloneTestBlockchainTime
:: forall m. (IOLike m, HasCallStack)
=> TestBlockchainTime m
-> ResourceRegistry m
-> m (TestBlockchainTime m)
cloneTestBlockchainTime testBtime registry = do
s <- atomically get
let btime' :: BlockchainTime m
btime' = BlockchainTime {
getCurrentSlot = get
, onSlotChange_ = fmap cancelThread .
onEachChange registry Running (Just (Running s)) get
}
return $ TestBlockchainTime
{ testBlockchainTime = btime'
, testBlockchainTimeDone
}
where
TestBlockchainTime{testBlockchainTime, testBlockchainTimeDone} = testBtime
BlockchainTime{getCurrentSlot = get} = testBlockchainTime
-- | Number of slot length changes if running for the specified number of slots
countSlotLengthChanges :: NumSlots -> SlotLengths -> Word64
countSlotLengthChanges = \(NumSlots n) -> go n
where
go :: Word64 -> SlotLengths -> Word64
go limit (SlotLengths _ mNext) =
case mNext of
Nothing -> 0
Just (SegmentLength n, next) ->
if limit > n
then 1 + go (limit - n) next
else 0