-
Notifications
You must be signed in to change notification settings - Fork 213
/
Slotting.hs
572 lines (513 loc) · 18.3 KB
/
Slotting.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
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Rank2Types #-}
-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- Contains tools for converting between @SlotNo@, @EpochNo@, @SlotInEpoch@,
-- @UTCTime@.
module Cardano.Wallet.Primitive.Slotting
( -- ** Queries
Qry
, currentEpoch
, epochOf
, slotToUTCTime
, slotToRelTime
, toSlotId
, slotRangeFromRelativeTimeRange
, slotRangeFromTimeRange
, firstSlotInEpoch
, ongoingSlotAt
, ceilingSlotAt
, timeOfEpoch
, getStartTime
-- ** Blockchain-relative times
, RelativeTime
, toRelativeTime
, toRelativeTimeRange
, fromRelativeTime
, addRelTime
-- ** What's the time?
, currentRelativeTime
, getCurrentTimeRelativeFromStart
-- ** Running queries
, TimeInterpreter (..)
, mkSingleEraInterpreter
, mkTimeInterpreter
, PastHorizonException (..)
, interpretQuery
, TimeInterpreterLog (..)
-- ** Combinators for running queries
, unsafeExtendSafeZone
, neverFails
, hoistTimeInterpreter
, expectAndThrowFailures
) where
import Prelude
import Cardano.BM.Data.Severity
( Severity (..) )
import Cardano.BM.Data.Tracer
( HasSeverityAnnotation (..) )
import Cardano.Wallet.Orphans
()
import Cardano.Wallet.Primitive.Types
( EpochLength (..)
, EpochNo (..)
, Range (..)
, SlotId (..)
, SlotInEpoch (..)
, SlotLength (..)
, SlotNo (..)
, SlottingParameters (..)
, StartTime (..)
)
import Control.Monad
( ap, join, liftM, (>=>) )
import Control.Monad.IO.Class
( MonadIO, liftIO )
import Control.Monad.Trans.Class
( lift )
import Control.Monad.Trans.Except
( ExceptT (..), runExceptT )
import Control.Tracer
( Tracer, contramap, natTracer, nullTracer, traceWith )
import Data.Coerce
( coerce )
import Data.Functor.Identity
( Identity )
import Data.Generics.Internal.VL.Lens
( (^.) )
import Data.Kind
( Type )
import Data.Maybe
( fromMaybe )
import Data.Text
( Text )
import Data.Text.Class
( ToText (..) )
import Data.Time.Clock
( NominalDiffTime, UTCTime, addUTCTime, getCurrentTime )
import Data.Word
( Word32, Word64 )
import Fmt
( blockListF', build, fmt, indentF )
import GHC.Stack
( CallStack, HasCallStack, getCallStack, prettySrcLoc )
import Ouroboros.Consensus.BlockchainTime.WallClock.Types
( RelativeTime (..), SystemStart (..), addRelTime )
import Ouroboros.Consensus.HardFork.History.Qry
( Expr (..)
, Interpreter
, PastHorizonException (..)
, epochToSlot'
, mkInterpreter
, qryFromExpr
, slotToEpoch'
, slotToWallclock
, wallclockToSlot
)
import Ouroboros.Consensus.HardFork.History.Summary
( neverForksSummary )
import UnliftIO.Exception
( throwIO )
import qualified Cardano.Slotting.Slot as Cardano
import qualified Data.Text as T
import qualified Ouroboros.Consensus.BlockchainTime.WallClock.Types as Cardano
import qualified Ouroboros.Consensus.HardFork.History.Qry as HF
import qualified Ouroboros.Consensus.HardFork.History.Summary as HF
{-------------------------------------------------------------------------------
Queries
-------------------------------------------------------------------------------}
-- | A query for time, slot and epoch conversions. Can be interpreted using
-- @interpretQuery@.
--
-- == Differences to the underlying consensus 'Ouroboros.Consensus.HardFork.History.Qry.Qry'
--
-- @HF.Qry@ can only be interpreted in a
-- single era. If you have
--
-- @
-- q1 = epochOf someSlotInByron
-- q2 = epochOf someSlotInShelley
-- @
--
-- @HF.interpretQuery@ could interpret both individually, but
--
-- @
-- q3 = q1 >> q2
-- @
--
-- would fail.
--
-- This wrapper exists to fix this.
--
-- We also provide @QStartTime@.
--
data Qry :: Type -> Type where
-- | A @HF.Qry@ can only be run inside a single era.
EraContainedQry :: HF.Qry a -> Qry a
QStartTime :: Qry StartTime
QPure :: a -> Qry a
QBind :: Qry a -> (a -> Qry b) -> Qry b
instance Functor Qry where
fmap = liftM
instance Applicative Qry where
pure = QPure
(<*>) = ap
instance Monad Qry where
return = pure
(>>=) = QBind
runQuery
:: HasCallStack
=> StartTime
-> Interpreter xs
-> Qry a
-> Either HF.PastHorizonException a
runQuery startTime int = go
where
go :: Qry a -> Either HF.PastHorizonException a
go (EraContainedQry q) = HF.interpretQuery int q
go (QPure a) =
return a
go (QBind x f) = do
go x >>= go . f
go (QStartTime) =
return startTime
-- | Query the blockchain start time. This is part of the 'TimeInterpreter'
-- environment.
getStartTime :: Qry StartTime
getStartTime = QStartTime
-- | Query the epoch corresponding to a flat slot number.
epochOf :: SlotNo -> Qry EpochNo
epochOf slot = epochNumber <$> toSlotId slot
-- | Query to convert a flat 'SlotNo' to a 'SlotId', which is the epoch number,
-- and the local slot index.
toSlotId :: SlotNo -> Qry SlotId
toSlotId slot = do
(e, s) <- EraContainedQry $ slotToEpoch' slot
return $ SlotId
(EpochNo $ fromIntegral $ Cardano.unEpochNo e)
(SlotInEpoch $ downCast s)
where
downCast :: Word64 -> Word32
downCast = fromIntegral
-- | Query the absolute time at which a slot starts.
slotToUTCTime :: SlotNo -> Qry UTCTime
slotToUTCTime sl = slotToRelTime sl >>= fromRelativeTime
-- | Query the relative time at which a slot starts.
slotToRelTime :: SlotNo -> Qry RelativeTime
slotToRelTime = EraContainedQry . fmap fst . slotToWallclock
-- | Query the absolute times at which an epoch starts and ends.
--
-- Querying the end time of /this/ epoch is preferable to querying the start
-- time of the /next/ epoch, because the next epoch may be outside the forecast
-- range, and result in 'PastHorizonException'.
timeOfEpoch :: EpochNo -> Qry (UTCTime, UTCTime)
timeOfEpoch epoch = do
ref <- firstSlotInEpoch epoch
refTime <- slotToUTCTime ref
el <- EraContainedQry $ qryFromExpr $ EEpochSize $ ELit $ toCardanoEpochNo epoch
sl <- EraContainedQry $ qryFromExpr $ ESlotLength $ ELit ref
let convert = fromRational . toRational
let el' = convert $ Cardano.unEpochSize el
let sl' = Cardano.getSlotLength sl
let timeInEpoch = el' * sl'
return (refTime, timeInEpoch `addUTCTime` refTime)
where
toCardanoEpochNo (EpochNo e) = Cardano.EpochNo $ fromIntegral e
-- | Translate 'EpochNo' to the 'SlotNo' of the first slot in that epoch
firstSlotInEpoch :: EpochNo -> Qry SlotNo
firstSlotInEpoch = EraContainedQry . epochToSlot' . convertEpochNo
where
convertEpochNo (EpochNo e) = Cardano.EpochNo $ fromIntegral e
-- @@
-- slot:
-- |1--------|2----------
--
-- result of onGoingSlotAt:
-- ●---------○
-- 1
-- ●----------○
-- 2
-- @@
--
--
ongoingSlotAt :: RelativeTime -> Qry SlotNo
ongoingSlotAt = fmap fst . slotAtTimeDetailed
-- @@
-- slot:
-- |1--------|2----------
--
-- result of ceilingSlotAt:
-- ○---------●
-- 2
-- ○----------●
-- 3
-- @@
--
ceilingSlotAt :: RelativeTime -> Qry SlotNo
ceilingSlotAt = fmap ceil2 . slotAtTimeDetailed
where
ceil2 (s, 0) = s
ceil2 (s, _) = s + 1
-- | Helper that returns @(slot, elapsedTimeInSlot)@ for a
-- given @UTCTime@.
slotAtTimeDetailed :: RelativeTime -> Qry (SlotNo, NominalDiffTime)
slotAtTimeDetailed = EraContainedQry . fmap dropThird . wallclockToSlot
where
dropThird (a, b, _) = (a, b)
-- | This function returns a chain-relative time range if (and only if) the
-- specified UTC time range intersects with the life of the blockchain.
--
-- If, on the other hand, the specified time range terminates before the start
-- of the blockchain, this function returns 'Nothing'.
toRelativeTimeRange :: Range UTCTime -> StartTime -> Maybe (Range RelativeTime)
toRelativeTimeRange range start = case toRelativeTime start <$> range of
Range _ (Just Nothing) -> Nothing
Range a b -> Just (Range (fromMaybe (RelativeTime 0) <$> a) (join b))
-- | Transforms the given inclusive time range into an inclusive slot range.
slotRangeFromRelativeTimeRange :: Range RelativeTime -> Qry (Range SlotNo)
slotRangeFromRelativeTimeRange (Range a b) =
Range <$> traverse ceilingSlotAt a <*> traverse ongoingSlotAt b
slotRangeFromTimeRange :: Range UTCTime -> Qry (Maybe (Range SlotNo))
slotRangeFromTimeRange range = getStartTime >>=
mapM slotRangeFromRelativeTimeRange . toRelativeTimeRange range
{-------------------------------------------------------------------------------
Blockchain-relative time
-------------------------------------------------------------------------------}
-- | Same as 'Cardano.toRelativeTime', but has error handling for times before
-- the system start. No other functions in this module will accept UTC times.
toRelativeTime :: StartTime -> UTCTime -> Maybe RelativeTime
toRelativeTime (StartTime start) utc
| utc < start = Nothing
| otherwise = Just $ Cardano.toRelativeTime (SystemStart start) utc
-- | Convert an absolute time to a relative time. If the absolute time is before
-- the system start, consider the relative time to be the system start
-- time. This function can never fail.
toRelativeTimeOrZero :: StartTime -> UTCTime -> RelativeTime
toRelativeTimeOrZero start = fromMaybe (RelativeTime 0) . toRelativeTime start
-- | Query the absolute time corresponding to a blockchain-relative time.
fromRelativeTime :: RelativeTime -> Qry UTCTime
fromRelativeTime t = do
start <- getStartTime
pure (Cardano.fromRelativeTime (coerce start) t)
{-------------------------------------------------------------------------------
What's the time?
-------------------------------------------------------------------------------}
-- | The current system time, compared to the given blockchain start time.
--
-- If the current time is before the system start (this would only happen when
-- launching testnets), let's just say we're in epoch 0.
--
-- TODO: Use io-sim-classes for easier testing.
getCurrentTimeRelativeFromStart :: StartTime -> IO RelativeTime
getCurrentTimeRelativeFromStart start =
toRelativeTimeOrZero start <$> getCurrentTime
-- | The current system time, compared to the blockchain start time of the given
-- 'TimeInterpreter'.
--
-- If the current time is before the system start (this would only happen when
-- launching testnets), the relative time is reported as 0.
currentRelativeTime :: MonadIO m => TimeInterpreter n -> m RelativeTime
currentRelativeTime =
liftIO . getCurrentTimeRelativeFromStart . blockchainStartTime
-- | Note: This fails when the node is far enough behind that we in the present
-- are beyond its safe zone.
currentEpoch :: MonadIO m => TimeInterpreter m -> m EpochNo
currentEpoch ti = do
now <- currentRelativeTime ti
interpretQuery ti (ongoingSlotAt now >>= epochOf)
{-------------------------------------------------------------------------------
Time Interpreter
-------------------------------------------------------------------------------}
-- | A @TimeInterpreter@ is a way for the wallet to run things of type @Qry a@,
-- with a system start time as context.
data TimeInterpreter m = forall eras. TimeInterpreter
{ interpreter :: m (Interpreter eras)
, blockchainStartTime :: StartTime
, tracer :: Tracer m TimeInterpreterLog
, handleResult :: forall a. Either PastHorizonException a -> m a
}
data TimeInterpreterLog
= MsgInterpreterPastHorizon
(Maybe String) -- ^ Reason for why the failure should be impossible
StartTime
PastHorizonException
deriving (Eq, Show)
instance HasSeverityAnnotation TimeInterpreterLog where
getSeverityAnnotation = \case
MsgInterpreterPastHorizon Nothing _ _ -> Notice
MsgInterpreterPastHorizon{} -> Error
instance ToText TimeInterpreterLog where
toText = \case
MsgInterpreterPastHorizon Nothing t0 e -> mconcat
[ "Time interpreter queried past the horizon. "
, renderPastHorizonException e t0
]
MsgInterpreterPastHorizon (Just reason) t0 e -> mconcat
[ "Time interpreter queried past the horizon. "
, "This should not happen because "
, T.pack reason
, renderPastHorizonException e t0
]
where
renderPastHorizonException (PastHorizon callStack expr eras) t0 = mconcat
[ "\nCalled from:\n"
, prettyCallStackTop callStack
, "\nConverting expression:\n"
, T.pack $ show expr
, "\n\nWith knowledge about the following eras:\n"
, fmt $ indentF 4 $ blockListF' "-" eraSummaryF eras
, "\nt0 = "
, T.pack $ show t0
]
prettyCallStackTop :: CallStack -> Text
prettyCallStackTop callStack =
case reverse (getCallStack callStack) of
((_, srcLoc):_rest) -> T.pack $ show $ prettySrcLoc srcLoc
_ -> "Unknown"
eraSummaryF (HF.EraSummary start end _params) = mconcat
[ boundF start
, " to "
, endF end
]
endF (HF.EraEnd b) = boundF b
endF (HF.EraUnbounded) = "<unbounded>"
boundF (HF.Bound _time _slot epoch) = mconcat
[ build $ show epoch
]
-- | Run a query.
interpretQuery
:: HasCallStack
=> Monad m
=> TimeInterpreter m
-> Qry a
-> m a
interpretQuery (TimeInterpreter getI start tr handleRes) qry = do
i <- getI
let res = runQuery start i qry
case res of
Left e -> do
traceWith tr $ MsgInterpreterPastHorizon Nothing start e
Right _ -> pure ()
handleRes res
-- | An 'Interpreter' for a single era, where the @SlottingParameters@ cannot
-- change.
--
-- Queries will never fail with @mkSingleEraInterpreter@.
mkSingleEraInterpreter
:: HasCallStack
=> StartTime
-> SlottingParameters
-> TimeInterpreter Identity
mkSingleEraInterpreter start sp = TimeInterpreter
{ interpreter = pure int
, blockchainStartTime = start
, tracer = nullTracer
, handleResult = either bomb pure
}
where
int = mkInterpreter summary
summary = neverForksSummary sz len
sz = Cardano.EpochSize $ fromIntegral $ unEpochLength $ sp ^. #getEpochLength
len = Cardano.mkSlotLength $ unSlotLength $ sp ^. #getSlotLength
bomb x = error $ "mkSingleEraInterpreter: the impossible happened: " <> show x
-- | Set up a 'TimeInterpreter' for a given start time, and an 'Interpreter'
-- queried from the ledger layer.
mkTimeInterpreter
:: Monad m
=> Tracer m TimeInterpreterLog
-> StartTime
-> m (Interpreter eras)
-> TimeInterpreter (ExceptT PastHorizonException m)
mkTimeInterpreter tr start int = TimeInterpreter
{ interpreter = lift int
, blockchainStartTime = start
, tracer = natTracer lift tr
, handleResult = ExceptT . pure
}
{-------------------------------------------------------------------------------
Time Interpreter combinators
-------------------------------------------------------------------------------}
-- | Takes a motivation of why @TimeInterpreter@ shouldn't fail interpreting
-- queries.
--
-- Unexpected @PastHorizonException@s will be thrown in IO, and traced with
-- Error severity along with the provided motivation.
neverFails
:: String
-> TimeInterpreter (ExceptT PastHorizonException IO)
-> TimeInterpreter IO
neverFails reason = f . hoistTimeInterpreter (runExceptT >=> eitherToIO)
where
eitherToIO (Right x) = pure x
eitherToIO (Left e) = throwIO e
f (TimeInterpreter getI ss tr h) = TimeInterpreter
{ interpreter = getI
, blockchainStartTime = ss
, tracer = contramap (setReason reason) tr
, handleResult = h
}
setReason r (MsgInterpreterPastHorizon _ t0 e)
= MsgInterpreterPastHorizon (Just r) t0 e
-- | Makes @PastHorizonException@ be thrown in @IO@.
--
-- Will /not/ cause @PastHorizonException@ to be tracer with Error severity,
-- unlike @neverFails@.
expectAndThrowFailures
:: TimeInterpreter (ExceptT PastHorizonException IO)
-> TimeInterpreter IO
expectAndThrowFailures = hoistTimeInterpreter (runExceptT >=> eitherToIO)
where
eitherToIO (Right x) = pure x
eitherToIO (Left e) = throwIO e
-- | Change the underlying monad of the TimeInterpreter with a natural
-- transformation.
hoistTimeInterpreter
:: (forall a. m a -> n a)
-> TimeInterpreter m
-> TimeInterpreter n
hoistTimeInterpreter f (TimeInterpreter getI ss tr h) = TimeInterpreter
{ interpreter = f getI
-- NOTE: interpreter ti cannot throw PastHorizonException, but
-- this way we don't have to carry around yet another type parameter.
, blockchainStartTime = ss
, tracer = natTracer f tr
, handleResult = f . h
}
-- | Extend the safe zone to make the TimeInterpreter return predictions where
-- it otherwise would have failed with @PastHorizonException@. This should be
-- used with great caution, and if we can get away from it, that would also be
-- great. Also ADP-575.
--
-- From the underlying ouroboros-consensus function:
--
-- UNSAFE: extend the safe zone of the current era of the given 'Interpreter'
-- to be /unbounded/, ignoring any future hard forks.
--
-- This only has effect when the 'Interpreter' was obtained in an era that was
-- /not the final one/ (in the final era, this is a no-op). The 'Interpreter'
-- will be made to believe that the current era is the final era, making its
-- horizon unbounded, and thus never returning a 'PastHorizonException'.
--
-- Use of this function is /strongly discouraged/, as it will ignore any future
-- hard forks, and the results produced by the 'Interpreter' can thus be
-- incorrect.
unsafeExtendSafeZone
:: TimeInterpreter (ExceptT PastHorizonException IO)
-> TimeInterpreter IO
unsafeExtendSafeZone = f . neverFails r
where
f (TimeInterpreter getI ss tr h) = TimeInterpreter
{ interpreter = HF.unsafeExtendSafeZone <$> getI
, blockchainStartTime = ss
, tracer = tr
, handleResult = h
}
r = "unsafeExtendSafeZone should make PastHorizonExceptions impossible."