{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}

module Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck
  ( -- * Interface
    HeaderInFutureCheck (..)
  , SomeHeaderInFutureCheck (..)

    -- * Real Implementation
  , HeaderArrivalException (..)
  , realHeaderInFutureCheck

    -- * Clock skew
  , clockSkewInSeconds
  , defaultClockSkew

    -- ** not exporting the constructor
  , 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)

{-------------------------------------------------------------------------------
  Interface
-------------------------------------------------------------------------------}

data SomeHeaderInFutureCheck m blk
  = forall arrival judgment.
    SomeHeaderInFutureCheck (HeaderInFutureCheck m blk arrival judgment)

-- | The interface a ChainSync client needs in order to check the arrival time
-- of headers.
--
-- Instead of alphabetical, the fields are in the order in which the ChainSync
-- client logic will invoke them for each header.
data HeaderInFutureCheck m blk arrival judgment = HeaderInFutureCheck
  { forall (m :: * -> *) blk arrival judgment.
HeaderInFutureCheck m blk arrival judgment -> Proxy arrival
proxyArrival :: Proxy arrival
  , forall (m :: * -> *) blk arrival judgment.
HeaderInFutureCheck m blk arrival judgment
-> Header blk -> m arrival
recordHeaderArrival :: Header blk -> m arrival
  -- ^ This is ideally called _immediately_ upon the header arriving.
  , forall (m :: * -> *) blk arrival judgment.
HeaderInFutureCheck m blk arrival judgment
-> LedgerConfig blk
-> LedgerState blk EmptyMK
-> arrival
-> Except PastHorizonException judgment
judgeHeaderArrival ::
      LedgerConfig blk ->
      LedgerState blk EmptyMK ->
      arrival ->
      Except PastHorizonException judgment
  -- ^ Judge what to do about the header's arrival time.
  --
  -- Note that this may be called after a delay, hence @arrival@ contains at
  -- least the arrival time.
  --
  -- In particular, such a delay might be caused by waiting for the
  -- intersection with the local selection to change after this function
  -- returns 'Ouroboros.Consensus.HardFork.HistoryPastHorizon'.
  , forall (m :: * -> *) blk arrival judgment.
HeaderInFutureCheck m blk arrival judgment
-> judgment -> m (Except HeaderArrivalException RelativeTime)
handleHeaderArrival ::
      judgment ->
      m (Except HeaderArrivalException RelativeTime)
  -- ^ Enact the judgment.
  --
  -- On success, return the slot time of the header; otherwise, an exception
  -- should be raised.
  }

{-------------------------------------------------------------------------------
  Real implmementation
-------------------------------------------------------------------------------}

data HeaderArrivalException
  = -- | The header arrived so early that its issuer either minted it before
    -- their clock reached its slot onset or else the difference between their
    -- clock and ours is more severe than we're configured to tolerate.
    --
    -- INVARIANT: @'tolerableClockSkew' < negate 'ageUponArrival'@
    forall blk. HasHeader blk => FarFutureHeaderException
    { 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
realHeaderInFutureCheck :: forall blk (m :: * -> *).
(HasHeader blk, HasHeader (Header blk), HasHardForkHistory blk,
 MonadDelay m) =>
ClockSkew -> SystemTime m -> SomeHeaderInFutureCheck m blk
realHeaderInFutureCheck 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
          -- TODO cache this in the KnownIntersectionState? Or even in the
          -- LedgerDB?
          (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_
          -- TODO leap seconds?

          -- this delay is the simple part of Ouroboros Chronos
          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 -- TODO leap seconds?
          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
                  }
            -- no exception if within skew
            RelativeTime -> Except HeaderArrivalException RelativeTime
forall a. a -> ExceptT HeaderArrivalException Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RelativeTime
onset
      }

{-------------------------------------------------------------------------------
  Clock skew
-------------------------------------------------------------------------------}

-- | Maximum permissible clock skew
--
-- When running NTP, systems clocks will never be perfectly synchronized. The
-- maximum clock skew records how much of a difference we consider acceptable.
--
-- For example. Suppose
--
-- * Two nodes A and B
-- * A's clock is 0.5 ahead of B's
-- * A produces a block and sends it to B
-- * When B translates the 'SlotNo' of that block to a time, it may find that
--   it is 0.5 seconds ahead of its current clock (worst case).
--
-- The maximum permissible clock skew decides if B will consider this block to
-- be valid (even if it will not yet consider it for chain seleciton) or as
-- invalid (and disconnect from A, since A is sending it invalid blocks).
--
-- Use 'defaultClockSkew' when unsure.
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)

-- | Default maximum permissible clock skew
--
-- See 'ClockSkew' for details. We allow for 2 seconds skew by default.
defaultClockSkew :: ClockSkew
defaultClockSkew :: ClockSkew
defaultClockSkew = Double -> ClockSkew
clockSkewInSeconds Double
2

-- | Specify maximum clock skew in seconds
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