{-# 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
  { forall (m :: * -> *) blk.
HistoricityCheck m blk
-> HistoricalChainSyncMessage
-> HeaderStateWithTime blk
-> m (Either HistoricityException ())
judgeMessageHistoricity ::
      HistoricalChainSyncMessage ->
      HeaderStateWithTime blk ->
      m (Either HistoricityException ())
  -- ^ 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.
  }

-- | 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
    , ()
historicalPoint :: !(Point blk)
    -- ^ Depending on 'historicalMessage':
    --
    --  * 'HistoricalMsgRollBackward': The oldest header that was rewound.
    --
    --  * 'HistoricalMsgAwaitReply': The tip of the candidate fragment.
    , HistoricityException -> RelativeTime
slotTime :: !RelativeTime
    -- ^ The time corresponding to the slot of 'historicalPoint'.
    , HistoricityException -> RelativeTime
arrivalTime :: !RelativeTime
    -- ^ When the offending 'historicalMessage' was received.
    , 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 ->
  -- | 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.
  m GsmState ->
  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
            }