{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
module Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck
(
HistoricalChainSyncMessage (..)
, HistoricityCheck (..)
, HistoricityCutoff (..)
, HistoricityException (..)
, 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 (..))
data HistoricityCheck m blk = HistoricityCheck
{ forall (m :: * -> *) blk.
HistoricityCheck m blk
-> HistoricalChainSyncMessage
-> HeaderStateWithTime blk
-> m (Either HistoricityException ())
judgeMessageHistoricity ::
HistoricalChainSyncMessage ->
HeaderStateWithTime blk ->
m (Either HistoricityException ())
}
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
=
forall blk. HasHeader blk => HistoricityException
{ HistoricityException -> HistoricalChainSyncMessage
historicalMessage :: HistoricalChainSyncMessage
, ()
historicalPoint :: !(Point blk)
, HistoricityException -> RelativeTime
slotTime :: !RelativeTime
, 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)
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)
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 ()
}
mkCheck ::
forall m blk.
( Monad m
, HasHeader blk
, HasAnnTip blk
) =>
SystemTime m ->
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
}