{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}

module Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck (
    -- * Interface
    HistoricalChainSyncMessage (..)
  , HistoricityCheck (..)
  , HistoricityCutoff (..)
  , HistoricityException (..)
    -- * Real implementation
  , mkCheck
  , noCheck
  ) where

import           Control.Exception (Exception)
import           Control.Monad (when)
import           Control.Monad.Except (throwError)
import           Data.Time.Clock (NominalDiffTime)
import           Data.Typeable (eqT)
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.BlockchainTime (RelativeTime,
                     SystemTime (..), diffRelTime)
import           Ouroboros.Consensus.HeaderStateHistory
                     (HeaderStateWithTime (..))
import           Ouroboros.Consensus.HeaderValidation (HasAnnTip,
                     headerStatePoint)
import           Ouroboros.Consensus.Node.GsmState (GsmState (..))

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

-- | Interface for the ChainSync client for deciding whether @MsgRollBackward@s
-- and @MsgAwaitReply@s are historical.
data HistoricityCheck m blk = HistoricityCheck {
    -- | Determine whether the received message is historical. Depending on the
    -- first argument, the second argument is:
    --
    --  * 'HistoricalMsgRollBackward': The oldest state that was rolled back.
    --    (Note that rollbacks of depth zero are hence never historical.).
    --
    --  * 'HistoricalMsgAwaitReply': The state corresponding to the tip of the
    --    candidate fragment when @MsgAwaitReply@ was sent.
    forall (m :: * -> *) blk.
HistoricityCheck m blk
-> HistoricalChainSyncMessage
-> HeaderStateWithTime blk
-> m (Either HistoricityException ())
judgeMessageHistoricity ::
         HistoricalChainSyncMessage
      -> HeaderStateWithTime blk
      -> m (Either HistoricityException ())
  }

-- | ChainSync historicity checks are performed for @MsgRollBackward@s and
-- @MsgAwaitReply@s, see 'HistoricityCheck'.
data HistoricalChainSyncMessage =
    HistoricalMsgRollBackward
  | HistoricalMsgAwaitReply
  deriving stock (Int -> HistoricalChainSyncMessage -> ShowS
[HistoricalChainSyncMessage] -> ShowS
HistoricalChainSyncMessage -> String
(Int -> HistoricalChainSyncMessage -> ShowS)
-> (HistoricalChainSyncMessage -> String)
-> ([HistoricalChainSyncMessage] -> ShowS)
-> Show HistoricalChainSyncMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HistoricalChainSyncMessage -> ShowS
showsPrec :: Int -> HistoricalChainSyncMessage -> ShowS
$cshow :: HistoricalChainSyncMessage -> String
show :: HistoricalChainSyncMessage -> String
$cshowList :: [HistoricalChainSyncMessage] -> ShowS
showList :: [HistoricalChainSyncMessage] -> ShowS
Show, HistoricalChainSyncMessage -> HistoricalChainSyncMessage -> Bool
(HistoricalChainSyncMessage -> HistoricalChainSyncMessage -> Bool)
-> (HistoricalChainSyncMessage
    -> HistoricalChainSyncMessage -> Bool)
-> Eq HistoricalChainSyncMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HistoricalChainSyncMessage -> HistoricalChainSyncMessage -> Bool
== :: HistoricalChainSyncMessage -> HistoricalChainSyncMessage -> Bool
$c/= :: HistoricalChainSyncMessage -> HistoricalChainSyncMessage -> Bool
/= :: HistoricalChainSyncMessage -> HistoricalChainSyncMessage -> Bool
Eq)

data HistoricityException =
  -- | We received a @MsgRollBackward@ or a @MsgAwaitReply@ while their
  -- candidate chain was too old for it to plausibly have been sent by an honest
  -- caught-up peer.
  --
  -- INVARIANT: @'historicityCutoff' < 'arrivalTime' `diffRelTime` 'slotTime'@
  forall blk. HasHeader blk => HistoricityException {
      HistoricityException -> HistoricalChainSyncMessage
historicalMessage :: HistoricalChainSyncMessage
      -- | Depending on 'historicalMessage':
      --
      --  * 'HistoricalMsgRollBackward': The oldest header that was rewound.
      --
      --  * 'HistoricalMsgAwaitReply': The tip of the candidate fragment.
    , ()
historicalPoint   :: !(Point blk)
      -- | The time corresponding to the slot of 'historicalPoint'.
    , HistoricityException -> RelativeTime
slotTime          :: !RelativeTime
      -- | When the offending 'historicalMessage' was received.
    , HistoricityException -> RelativeTime
arrivalTime       :: !RelativeTime
    , HistoricityException -> HistoricityCutoff
historicityCutoff :: !HistoricityCutoff
    }
  deriving anyclass (Show HistoricityException
Typeable HistoricityException
(Typeable HistoricityException, Show HistoricityException) =>
(HistoricityException -> SomeException)
-> (SomeException -> Maybe HistoricityException)
-> (HistoricityException -> String)
-> (HistoricityException -> Bool)
-> Exception HistoricityException
SomeException -> Maybe HistoricityException
HistoricityException -> Bool
HistoricityException -> String
HistoricityException -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: HistoricityException -> SomeException
toException :: HistoricityException -> SomeException
$cfromException :: SomeException -> Maybe HistoricityException
fromException :: SomeException -> Maybe HistoricityException
$cdisplayException :: HistoricityException -> String
displayException :: HistoricityException -> String
$cbacktraceDesired :: HistoricityException -> Bool
backtraceDesired :: HistoricityException -> Bool
Exception)

deriving stock instance Show HistoricityException

instance Eq HistoricityException where
  == :: HistoricityException -> HistoricityException -> Bool
(==)
    (HistoricityException HistoricalChainSyncMessage
l0 (Point blk
l1 :: Point l) RelativeTime
l2 RelativeTime
l3 HistoricityCutoff
l4)
    (HistoricityException HistoricalChainSyncMessage
r0 (Point blk
r1 :: Point r) RelativeTime
r2 RelativeTime
r3 HistoricityCutoff
r4)
    = 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 -> (HistoricalChainSyncMessage
l0, Point blk
l1, RelativeTime
l2, RelativeTime
l3, HistoricityCutoff
l4) (HistoricalChainSyncMessage, Point blk, RelativeTime, RelativeTime,
 HistoricityCutoff)
-> (HistoricalChainSyncMessage, Point blk, RelativeTime,
    RelativeTime, HistoricityCutoff)
-> Bool
forall a. Eq a => a -> a -> Bool
== (HistoricalChainSyncMessage
r0, Point blk
Point blk
r1, RelativeTime
r2, RelativeTime
r3, HistoricityCutoff
r4)

-- ^ The maximum age of a @MsgRollBackward@ or @MsgAwaitReply@ at arrival time,
-- constraining the age of the oldest rewound header or the tip of the candidate
-- fragment, respectively.
--
-- This should be set to at least the maximum duration (across all eras) of a
-- stability window (the number of slots in which at least @k@ blocks are
-- guaranteed to arise).
--
-- For example, on Cardano mainnet today, the Praos Chain Growth property
-- implies that @3k/f@ (=129600) slots (=36 hours) will contain at least @k@
-- (=2160) blocks. (Byron has a smaller stability window, namely @2k@ (=24 hours
-- as the Byron slot length is 20s). Thus a peer rolling back a header that is
-- older than 36 hours or signals that it doesn't have more headers is either
-- violating the maximum rollback or else isn't a caught-up node. Either way, a
-- syncing node should not be connected to that peer.
newtype HistoricityCutoff = HistoricityCutoff {
    HistoricityCutoff -> NominalDiffTime
getHistoricityCutoff :: NominalDiffTime
  }
  deriving stock (Int -> HistoricityCutoff -> ShowS
[HistoricityCutoff] -> ShowS
HistoricityCutoff -> String
(Int -> HistoricityCutoff -> ShowS)
-> (HistoricityCutoff -> String)
-> ([HistoricityCutoff] -> ShowS)
-> Show HistoricityCutoff
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HistoricityCutoff -> ShowS
showsPrec :: Int -> HistoricityCutoff -> ShowS
$cshow :: HistoricityCutoff -> String
show :: HistoricityCutoff -> String
$cshowList :: [HistoricityCutoff] -> ShowS
showList :: [HistoricityCutoff] -> ShowS
Show, HistoricityCutoff -> HistoricityCutoff -> Bool
(HistoricityCutoff -> HistoricityCutoff -> Bool)
-> (HistoricityCutoff -> HistoricityCutoff -> Bool)
-> Eq HistoricityCutoff
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HistoricityCutoff -> HistoricityCutoff -> Bool
== :: HistoricityCutoff -> HistoricityCutoff -> Bool
$c/= :: HistoricityCutoff -> HistoricityCutoff -> Bool
/= :: HistoricityCutoff -> HistoricityCutoff -> Bool
Eq, Eq HistoricityCutoff
Eq HistoricityCutoff =>
(HistoricityCutoff -> HistoricityCutoff -> Ordering)
-> (HistoricityCutoff -> HistoricityCutoff -> Bool)
-> (HistoricityCutoff -> HistoricityCutoff -> Bool)
-> (HistoricityCutoff -> HistoricityCutoff -> Bool)
-> (HistoricityCutoff -> HistoricityCutoff -> Bool)
-> (HistoricityCutoff -> HistoricityCutoff -> HistoricityCutoff)
-> (HistoricityCutoff -> HistoricityCutoff -> HistoricityCutoff)
-> Ord HistoricityCutoff
HistoricityCutoff -> HistoricityCutoff -> Bool
HistoricityCutoff -> HistoricityCutoff -> Ordering
HistoricityCutoff -> HistoricityCutoff -> HistoricityCutoff
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 :: HistoricityCutoff -> HistoricityCutoff -> Ordering
compare :: HistoricityCutoff -> HistoricityCutoff -> Ordering
$c< :: HistoricityCutoff -> HistoricityCutoff -> Bool
< :: HistoricityCutoff -> HistoricityCutoff -> Bool
$c<= :: HistoricityCutoff -> HistoricityCutoff -> Bool
<= :: HistoricityCutoff -> HistoricityCutoff -> Bool
$c> :: HistoricityCutoff -> HistoricityCutoff -> Bool
> :: HistoricityCutoff -> HistoricityCutoff -> Bool
$c>= :: HistoricityCutoff -> HistoricityCutoff -> Bool
>= :: HistoricityCutoff -> HistoricityCutoff -> Bool
$cmax :: HistoricityCutoff -> HistoricityCutoff -> HistoricityCutoff
max :: HistoricityCutoff -> HistoricityCutoff -> HistoricityCutoff
$cmin :: HistoricityCutoff -> HistoricityCutoff -> HistoricityCutoff
min :: HistoricityCutoff -> HistoricityCutoff -> HistoricityCutoff
Ord)

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

-- | Do not perform any historicity checks. This is useful when we only sync
-- from trusted peers (Praos mode) or when the impact of historical messages is
-- already mitigated by other means (for example indirectly by the Limit on
-- Patience in the case of Genesis /without/ ChainSync Jumping).
noCheck :: Applicative m => HistoricityCheck m blk
noCheck :: forall (m :: * -> *) blk. Applicative m => HistoricityCheck m blk
noCheck = HistoricityCheck {
      judgeMessageHistoricity :: HistoricalChainSyncMessage
-> HeaderStateWithTime blk -> m (Either HistoricityException ())
judgeMessageHistoricity = \HistoricalChainSyncMessage
_msg HeaderStateWithTime blk
_hswt -> Either HistoricityException ()
-> m (Either HistoricityException ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HistoricityException ()
 -> m (Either HistoricityException ()))
-> Either HistoricityException ()
-> m (Either HistoricityException ())
forall a b. (a -> b) -> a -> b
$ () -> Either HistoricityException ()
forall a b. b -> Either a b
Right ()
    }

-- | Deny all rollbacks that rewind blocks older than
-- 'HistoricityCutoff' upon arrival.
mkCheck ::
     forall m blk.
     ( Monad m
     , HasHeader blk
     , HasAnnTip blk
     )
  => SystemTime m
  -> m GsmState
     -- ^ Get the current 'GsmState'.
     --
     -- This is used to disable the historicity check when we are caught up. The
     -- rationale is extra resilience against disconnects between honest nodes
     -- in disaster scenarios with very low chain density.
  -> HistoricityCutoff
  -> HistoricityCheck m blk
mkCheck :: forall (m :: * -> *) blk.
(Monad m, HasHeader blk, HasAnnTip blk) =>
SystemTime m
-> m GsmState -> HistoricityCutoff -> HistoricityCheck m blk
mkCheck SystemTime m
systemTime m GsmState
getCurrentGsmState HistoricityCutoff
cshc = HistoricityCheck {
      judgeMessageHistoricity :: HistoricalChainSyncMessage
-> HeaderStateWithTime blk -> m (Either HistoricityException ())
judgeMessageHistoricity = \HistoricalChainSyncMessage
msg HeaderStateWithTime blk
hswt -> m GsmState
getCurrentGsmState m GsmState
-> (GsmState -> m (Either HistoricityException ()))
-> m (Either HistoricityException ())
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          GsmState
PreSyncing -> HistoricalChainSyncMessage
-> HeaderStateWithTime blk -> m (Either HistoricityException ())
judgeRollback HistoricalChainSyncMessage
msg HeaderStateWithTime blk
hswt
          GsmState
Syncing    -> HistoricalChainSyncMessage
-> HeaderStateWithTime blk -> m (Either HistoricityException ())
judgeRollback HistoricalChainSyncMessage
msg HeaderStateWithTime blk
hswt
          GsmState
CaughtUp   -> Either HistoricityException ()
-> m (Either HistoricityException ())
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either HistoricityException ()
 -> m (Either HistoricityException ()))
-> Either HistoricityException ()
-> m (Either HistoricityException ())
forall a b. (a -> b) -> a -> b
$ () -> Either HistoricityException ()
forall a b. b -> Either a b
Right ()
    }
  where
    HistoricityCutoff NominalDiffTime
historicityCutoff = HistoricityCutoff
cshc

    judgeRollback ::
         HistoricalChainSyncMessage
      -> HeaderStateWithTime blk
      -> m (Either HistoricityException ())
    judgeRollback :: HistoricalChainSyncMessage
-> HeaderStateWithTime blk -> m (Either HistoricityException ())
judgeRollback HistoricalChainSyncMessage
msg (HeaderStateWithTime HeaderState blk
headerState RelativeTime
slotTime) = do
        arrivalTime <- SystemTime m -> m RelativeTime
forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeCurrent SystemTime m
systemTime
        let actualRollbackAge = RelativeTime
arrivalTime RelativeTime -> RelativeTime -> NominalDiffTime
`diffRelTime` RelativeTime
slotTime
        pure $ when (historicityCutoff < actualRollbackAge) $
          throwError HistoricityException {
              historicalMessage = msg
            , historicalPoint   = headerStatePoint headerState
            , slotTime
            , arrivalTime
            , historicityCutoff = cshc
            }