{-# 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
  ) 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)

{-------------------------------------------------------------------------------
  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
  ,
    -- | This is ideally called _immediately_ upon the header arriving.
    forall (m :: * -> *) blk arrival judgment.
HeaderInFutureCheck m blk arrival judgment
-> Header blk -> m arrival
recordHeaderArrival :: Header blk -> m arrival
  ,
    -- | 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
-> LedgerConfig blk
-> LedgerState blk
-> arrival
-> Except PastHorizonException judgment
judgeHeaderArrival ::
         LedgerConfig blk
      -> LedgerState blk
      -> arrival
      -> Except PastHorizonException judgment
  ,
    -- | Enact the judgment.
    --
    -- On success, return the slot time of the header; otherwise, an exception
    -- should be raised.
    forall (m :: * -> *) blk arrival judgment.
HeaderInFutureCheck m blk arrival judgment
-> judgment -> m (Except HeaderArrivalException RelativeTime)
handleHeaderArrival ::
         judgment
      -> m (Except HeaderArrivalException RelativeTime)
  }

{-------------------------------------------------------------------------------
  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), 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
              -- TODO cache this in the KnownIntersectionState? Or even in the
              -- LedgerDB?
        (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_
              -- 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
            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   -- note https://github.com/input-output-hk/io-sim/issues/129
                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   -- 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
  }