{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
module Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck (
HeaderInFutureCheck (..)
, SomeHeaderInFutureCheck (..)
, HeaderArrivalException (..)
, realHeaderInFutureCheck
) 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.Fragment.InFuture (ClockSkew, unClockSkew)
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 (LedgerConfig, LedgerState)
import Ouroboros.Consensus.Util.Time (nominalDelay)
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
-> 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), HasHeader 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
-> (RealPoint blk, RelativeTime)
-> Except
PastHorizonException (RealPoint blk, RelativeTime, RelativeTime)
judgeHeaderArrival = \LedgerConfig blk
lcfg LedgerState blk
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 -> Summary (HardForkIndices blk)
forall blk.
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk -> Summary (HardForkIndices blk)
hardForkSummary LedgerConfig blk
lcfg LedgerState blk
lst
(RelativeTime
onset, SlotLength
_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
(RealPoint blk, RelativeTime, RelativeTime)
-> Except
PastHorizonException (RealPoint blk, RelativeTime, RelativeTime)
forall a. a -> ExceptT PastHorizonException Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RealPoint blk
p, RelativeTime
arrivalTime_, RelativeTime
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
RelativeTime
now <- SystemTime m -> m RelativeTime
forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeCurrent SystemTime m
systemTime
let ageNow :: NominalDiffTime
ageNow = RelativeTime
now RelativeTime -> RelativeTime -> NominalDiffTime
`diffRelTime` RelativeTime
onset
syntheticDelay :: NominalDiffTime
syntheticDelay = NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a
negate NominalDiffTime
ageNow
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (NominalDiffTime
0 NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
< NominalDiffTime
syntheticDelay) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
DiffTime -> m ()
forall (m :: * -> *). MonadDelay m => DiffTime -> m ()
threadDelay (DiffTime -> m ()) -> DiffTime -> m ()
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> DiffTime
nominalDelay NominalDiffTime
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
}