{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
module Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck
(
HeaderInFutureCheck (..)
, SomeHeaderInFutureCheck (..)
, HeaderArrivalException (..)
, realHeaderInFutureCheck
, clockSkewInSeconds
, defaultClockSkew
, ClockSkew
, unClockSkew
) where
import Control.Exception (Exception)
import Control.Monad (unless, when)
import Control.Monad.Class.MonadTimer.SI (MonadDelay, threadDelay)
import Control.Monad.Except (Except, liftEither, throwError)
import Data.Proxy (Proxy (Proxy))
import Data.Time.Clock (NominalDiffTime)
import Data.Type.Equality ((:~:) (Refl))
import Data.Typeable (eqT)
import Ouroboros.Consensus.Block.Abstract (Header)
import Ouroboros.Consensus.Block.RealPoint
( RealPoint
, headerRealPoint
, realPointSlot
)
import Ouroboros.Consensus.BlockchainTime.WallClock.Types
( RelativeTime
, SystemTime
, diffRelTime
, systemTimeCurrent
)
import Ouroboros.Consensus.HardFork.Abstract
( HasHardForkHistory
, hardForkSummary
)
import Ouroboros.Consensus.HardFork.History (PastHorizonException)
import Ouroboros.Consensus.HardFork.History.Qry
( runQuery
, slotToWallclock
)
import Ouroboros.Consensus.Ledger.Basics
( EmptyMK
, LedgerConfig
, LedgerState
)
import Ouroboros.Consensus.Util.Time
( nominalDelay
, secondsToNominalDiffTime
)
import Ouroboros.Network.Block (HasHeader)
data m blk
= forall arrival judgment.
(HeaderInFutureCheck m blk arrival judgment)
data m blk arrival judgment =
{ forall (m :: * -> *) blk arrival judgment.
HeaderInFutureCheck m blk arrival judgment -> Proxy arrival
proxyArrival :: Proxy arrival
, :: Header blk -> m arrival
, ::
LedgerConfig blk ->
LedgerState blk EmptyMK ->
arrival ->
Except PastHorizonException judgment
, forall (m :: * -> *) blk arrival judgment.
HeaderInFutureCheck m blk arrival judgment
-> judgment -> m (Except HeaderArrivalException RelativeTime)
handleHeaderArrival ::
judgment ->
m (Except HeaderArrivalException RelativeTime)
}
data
=
forall blk. HasHeader blk =>
{ HeaderArrivalException -> NominalDiffTime
ageUponArrival :: !NominalDiffTime
, ()
arrivedPoint :: !(RealPoint blk)
, HeaderArrivalException -> RelativeTime
arrivalTime :: !RelativeTime
, HeaderArrivalException -> NominalDiffTime
tolerableClockSkew :: !NominalDiffTime
}
deriving instance Show HeaderArrivalException
instance Exception HeaderArrivalException
instance Eq HeaderArrivalException where
== :: HeaderArrivalException -> HeaderArrivalException -> Bool
(==)
(FarFutureHeaderException NominalDiffTime
l0 (RealPoint blk
l1 :: RealPoint l) RelativeTime
l2 NominalDiffTime
l3)
(FarFutureHeaderException NominalDiffTime
r0 (RealPoint blk
r1 :: RealPoint r) RelativeTime
r2 NominalDiffTime
r3) =
case forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT @l @r of
Maybe (blk :~: blk)
Nothing -> Bool
False
Just blk :~: blk
Refl -> (NominalDiffTime
l0, RealPoint blk
l1, RelativeTime
l2, NominalDiffTime
l3) (NominalDiffTime, RealPoint blk, RelativeTime, NominalDiffTime)
-> (NominalDiffTime, RealPoint blk, RelativeTime, NominalDiffTime)
-> Bool
forall a. Eq a => a -> a -> Bool
== (NominalDiffTime
r0, RealPoint blk
RealPoint blk
r1, RelativeTime
r2, NominalDiffTime
r3)
realHeaderInFutureCheck ::
( HasHeader blk
, HasHeader (Header blk)
, HasHardForkHistory blk
, MonadDelay m
) =>
ClockSkew -> SystemTime m -> SomeHeaderInFutureCheck m blk
ClockSkew
skew SystemTime m
systemTime =
HeaderInFutureCheck
m
blk
(RealPoint blk, RelativeTime)
(RealPoint blk, RelativeTime, RelativeTime)
-> SomeHeaderInFutureCheck m blk
forall (m :: * -> *) blk arrival judgment.
HeaderInFutureCheck m blk arrival judgment
-> SomeHeaderInFutureCheck m blk
SomeHeaderInFutureCheck (HeaderInFutureCheck
m
blk
(RealPoint blk, RelativeTime)
(RealPoint blk, RelativeTime, RelativeTime)
-> SomeHeaderInFutureCheck m blk)
-> HeaderInFutureCheck
m
blk
(RealPoint blk, RelativeTime)
(RealPoint blk, RelativeTime, RelativeTime)
-> SomeHeaderInFutureCheck m blk
forall a b. (a -> b) -> a -> b
$
HeaderInFutureCheck
{ proxyArrival :: Proxy (RealPoint blk, RelativeTime)
proxyArrival = Proxy (RealPoint blk, RelativeTime)
forall {k} (t :: k). Proxy t
Proxy
, recordHeaderArrival :: Header blk -> m (RealPoint blk, RelativeTime)
recordHeaderArrival = \Header blk
hdr -> do
(,) (Header blk -> RealPoint blk
forall blk. HasHeader (Header blk) => Header blk -> RealPoint blk
headerRealPoint Header blk
hdr) (RelativeTime -> (RealPoint blk, RelativeTime))
-> m RelativeTime -> m (RealPoint blk, RelativeTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SystemTime m -> m RelativeTime
forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeCurrent SystemTime m
systemTime
, judgeHeaderArrival :: LedgerConfig blk
-> LedgerState blk EmptyMK
-> (RealPoint blk, RelativeTime)
-> Except
PastHorizonException (RealPoint blk, RelativeTime, RelativeTime)
judgeHeaderArrival = \LedgerConfig blk
lcfg LedgerState blk EmptyMK
lst (RealPoint blk
p, RelativeTime
arrivalTime_) -> do
let qry :: Qry (RelativeTime, SlotLength)
qry = SlotNo -> Qry (RelativeTime, SlotLength)
slotToWallclock (RealPoint blk -> SlotNo
forall blk. RealPoint blk -> SlotNo
realPointSlot RealPoint blk
p)
hfSummary :: Summary (HardForkIndices blk)
hfSummary = LedgerConfig blk
-> LedgerState blk EmptyMK -> Summary (HardForkIndices blk)
forall blk (mk :: MapKind).
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
forall (mk :: MapKind).
LedgerConfig blk
-> LedgerState blk mk -> Summary (HardForkIndices blk)
hardForkSummary LedgerConfig blk
lcfg LedgerState blk EmptyMK
lst
(onset, _slotLength) <- Either PastHorizonException (RelativeTime, SlotLength)
-> ExceptT PastHorizonException Identity (RelativeTime, SlotLength)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either PastHorizonException (RelativeTime, SlotLength)
-> ExceptT
PastHorizonException Identity (RelativeTime, SlotLength))
-> Either PastHorizonException (RelativeTime, SlotLength)
-> ExceptT PastHorizonException Identity (RelativeTime, SlotLength)
forall a b. (a -> b) -> a -> b
$ Qry (RelativeTime, SlotLength)
-> Summary (HardForkIndices blk)
-> Either PastHorizonException (RelativeTime, SlotLength)
forall a (xs :: [*]).
HasCallStack =>
Qry a -> Summary xs -> Either PastHorizonException a
runQuery Qry (RelativeTime, SlotLength)
qry Summary (HardForkIndices blk)
hfSummary
pure (p, arrivalTime_, onset)
, handleHeaderArrival :: (RealPoint blk, RelativeTime, RelativeTime)
-> m (Except HeaderArrivalException RelativeTime)
handleHeaderArrival = \(RealPoint blk
p, RelativeTime
arrivalTime_, RelativeTime
onset) -> do
let ageUponArrival_ :: NominalDiffTime
ageUponArrival_ = RelativeTime
arrivalTime_ RelativeTime -> RelativeTime -> NominalDiffTime
`diffRelTime` RelativeTime
onset
tooEarly :: Bool
tooEarly = ClockSkew -> NominalDiffTime
unClockSkew ClockSkew
skew NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
negate NominalDiffTime
ageUponArrival_
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
tooEarly (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
now <- SystemTime m -> m RelativeTime
forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeCurrent SystemTime m
systemTime
let ageNow = RelativeTime
now RelativeTime -> RelativeTime -> NominalDiffTime
`diffRelTime` RelativeTime
onset
syntheticDelay = NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
negate NominalDiffTime
ageNow
threadDelay $ nominalDelay syntheticDelay
Except HeaderArrivalException RelativeTime
-> m (Except HeaderArrivalException RelativeTime)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Except HeaderArrivalException RelativeTime
-> m (Except HeaderArrivalException RelativeTime))
-> Except HeaderArrivalException RelativeTime
-> m (Except HeaderArrivalException RelativeTime)
forall a b. (a -> b) -> a -> b
$ do
Bool
-> ExceptT HeaderArrivalException Identity ()
-> ExceptT HeaderArrivalException Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tooEarly (ExceptT HeaderArrivalException Identity ()
-> ExceptT HeaderArrivalException Identity ())
-> ExceptT HeaderArrivalException Identity ()
-> ExceptT HeaderArrivalException Identity ()
forall a b. (a -> b) -> a -> b
$
HeaderArrivalException
-> ExceptT HeaderArrivalException Identity ()
forall a.
HeaderArrivalException -> ExceptT HeaderArrivalException Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
FarFutureHeaderException
{ ageUponArrival :: NominalDiffTime
ageUponArrival = NominalDiffTime
ageUponArrival_
, arrivedPoint :: RealPoint blk
arrivedPoint = RealPoint blk
p
, arrivalTime :: RelativeTime
arrivalTime = RelativeTime
arrivalTime_
, tolerableClockSkew :: NominalDiffTime
tolerableClockSkew = ClockSkew -> NominalDiffTime
unClockSkew ClockSkew
skew
}
RelativeTime -> Except HeaderArrivalException RelativeTime
forall a. a -> ExceptT HeaderArrivalException Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RelativeTime
onset
}
newtype ClockSkew = ClockSkew {ClockSkew -> NominalDiffTime
unClockSkew :: NominalDiffTime}
deriving (Int -> ClockSkew -> ShowS
[ClockSkew] -> ShowS
ClockSkew -> String
(Int -> ClockSkew -> ShowS)
-> (ClockSkew -> String)
-> ([ClockSkew] -> ShowS)
-> Show ClockSkew
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClockSkew -> ShowS
showsPrec :: Int -> ClockSkew -> ShowS
$cshow :: ClockSkew -> String
show :: ClockSkew -> String
$cshowList :: [ClockSkew] -> ShowS
showList :: [ClockSkew] -> ShowS
Show, ClockSkew -> ClockSkew -> Bool
(ClockSkew -> ClockSkew -> Bool)
-> (ClockSkew -> ClockSkew -> Bool) -> Eq ClockSkew
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ClockSkew -> ClockSkew -> Bool
== :: ClockSkew -> ClockSkew -> Bool
$c/= :: ClockSkew -> ClockSkew -> Bool
/= :: ClockSkew -> ClockSkew -> Bool
Eq, Eq ClockSkew
Eq ClockSkew =>
(ClockSkew -> ClockSkew -> Ordering)
-> (ClockSkew -> ClockSkew -> Bool)
-> (ClockSkew -> ClockSkew -> Bool)
-> (ClockSkew -> ClockSkew -> Bool)
-> (ClockSkew -> ClockSkew -> Bool)
-> (ClockSkew -> ClockSkew -> ClockSkew)
-> (ClockSkew -> ClockSkew -> ClockSkew)
-> Ord ClockSkew
ClockSkew -> ClockSkew -> Bool
ClockSkew -> ClockSkew -> Ordering
ClockSkew -> ClockSkew -> ClockSkew
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ClockSkew -> ClockSkew -> Ordering
compare :: ClockSkew -> ClockSkew -> Ordering
$c< :: ClockSkew -> ClockSkew -> Bool
< :: ClockSkew -> ClockSkew -> Bool
$c<= :: ClockSkew -> ClockSkew -> Bool
<= :: ClockSkew -> ClockSkew -> Bool
$c> :: ClockSkew -> ClockSkew -> Bool
> :: ClockSkew -> ClockSkew -> Bool
$c>= :: ClockSkew -> ClockSkew -> Bool
>= :: ClockSkew -> ClockSkew -> Bool
$cmax :: ClockSkew -> ClockSkew -> ClockSkew
max :: ClockSkew -> ClockSkew -> ClockSkew
$cmin :: ClockSkew -> ClockSkew -> ClockSkew
min :: ClockSkew -> ClockSkew -> ClockSkew
Ord)
defaultClockSkew :: ClockSkew
defaultClockSkew :: ClockSkew
defaultClockSkew = Double -> ClockSkew
clockSkewInSeconds Double
2
clockSkewInSeconds :: Double -> ClockSkew
clockSkewInSeconds :: Double -> ClockSkew
clockSkewInSeconds = NominalDiffTime -> ClockSkew
ClockSkew (NominalDiffTime -> ClockSkew)
-> (Double -> NominalDiffTime) -> Double -> ClockSkew
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> NominalDiffTime
secondsToNominalDiffTime