{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Ouroboros.Consensus.Fragment.InFuture (
CheckInFuture (..)
, InFuture (..)
, reference
, clockSkewInSeconds
, defaultClockSkew
, ClockSkew
, unClockSkew
, dontCheck
, miracle
) where
import Control.Monad.Class.MonadSTM
import Data.Bifunctor
import Data.Time (NominalDiffTime)
import Data.Word
import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime
import Ouroboros.Consensus.Fragment.Validated (ValidatedFragment)
import qualified Ouroboros.Consensus.Fragment.Validated as VF
import Ouroboros.Consensus.HardFork.Abstract
import qualified Ouroboros.Consensus.HardFork.History as HF
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment
(InvalidBlockPunishment)
import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as InvalidBlockPunishment
import Ouroboros.Consensus.Util.Time
import Ouroboros.Network.AnchoredFragment (AnchoredFragment,
AnchoredSeq (Empty, (:>)))
data CheckInFuture m blk = CheckInFuture {
forall (m :: * -> *) blk.
CheckInFuture m blk
-> ValidatedFragment (Header blk) (LedgerState blk)
-> m (AnchoredFragment (Header blk), [InFuture m blk])
checkInFuture :: ValidatedFragment (Header blk) (LedgerState blk)
-> m (AnchoredFragment (Header blk), [InFuture m blk])
}
deriving Context -> CheckInFuture m blk -> IO (Maybe ThunkInfo)
Proxy (CheckInFuture m blk) -> String
(Context -> CheckInFuture m blk -> IO (Maybe ThunkInfo))
-> (Context -> CheckInFuture m blk -> IO (Maybe ThunkInfo))
-> (Proxy (CheckInFuture m blk) -> String)
-> NoThunks (CheckInFuture m blk)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
forall (m :: * -> *) blk.
Context -> CheckInFuture m blk -> IO (Maybe ThunkInfo)
forall (m :: * -> *) blk. Proxy (CheckInFuture m blk) -> String
$cnoThunks :: forall (m :: * -> *) blk.
Context -> CheckInFuture m blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> CheckInFuture m blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) blk.
Context -> CheckInFuture m blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> CheckInFuture m blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (m :: * -> *) blk. Proxy (CheckInFuture m blk) -> String
showTypeOf :: Proxy (CheckInFuture m blk) -> String
NoThunks
via OnlyCheckWhnfNamed "CheckInFuture" (CheckInFuture m blk)
data InFuture m blk = InFuture {
:: Header blk
, forall (m :: * -> *) blk. InFuture m blk -> Bool
inFutureExceedsClockSkew :: Bool
, forall (m :: * -> *) blk.
InFuture m blk -> InvalidBlockPunishment m
inFuturePunish :: InvalidBlockPunishment m
}
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)
defaultClockSkew :: ClockSkew
defaultClockSkew :: ClockSkew
defaultClockSkew = Double -> ClockSkew
clockSkewInSeconds Double
2
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
reference :: forall m blk. (Monad m, UpdateLedger blk, HasHardForkHistory blk)
=> LedgerConfig blk
-> ClockSkew
-> SystemTime m
-> CheckInFuture m blk
reference :: forall (m :: * -> *) blk.
(Monad m, UpdateLedger blk, HasHardForkHistory blk) =>
LedgerConfig blk
-> ClockSkew -> SystemTime m -> CheckInFuture m blk
reference LedgerConfig blk
cfg (ClockSkew NominalDiffTime
clockSkew) SystemTime{m ()
m RelativeTime
systemTimeCurrent :: m RelativeTime
systemTimeWait :: m ()
systemTimeCurrent :: forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeWait :: forall (m :: * -> *). SystemTime m -> m ()
..} = CheckInFuture {
checkInFuture :: ValidatedFragment (Header blk) (LedgerState blk)
-> m (AnchoredFragment (Header blk), [InFuture m blk])
checkInFuture = \ValidatedFragment (Header blk) (LedgerState blk)
validated -> do
RelativeTime
now <- m RelativeTime
systemTimeCurrent
(AnchoredFragment (Header blk), [InFuture m blk])
-> m (AnchoredFragment (Header blk), [InFuture m blk])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((AnchoredFragment (Header blk), [InFuture m blk])
-> m (AnchoredFragment (Header blk), [InFuture m blk]))
-> (AnchoredFragment (Header blk), [InFuture m blk])
-> m (AnchoredFragment (Header blk), [InFuture m blk])
forall a b. (a -> b) -> a -> b
$
Summary (HardForkIndices blk)
-> RelativeTime
-> AnchoredFragment (Header blk)
-> (AnchoredFragment (Header blk), [InFuture m blk])
checkFragment
(LedgerConfig blk
-> LedgerState blk -> Summary (HardForkIndices blk)
forall blk.
HasHardForkHistory blk =>
LedgerConfig blk
-> LedgerState blk -> Summary (HardForkIndices blk)
hardForkSummary LedgerConfig blk
cfg (ValidatedFragment (Header blk) (LedgerState blk) -> LedgerState blk
forall b l. ValidatedFragment b l -> l
VF.validatedLedger ValidatedFragment (Header blk) (LedgerState blk)
validated))
RelativeTime
now
(ValidatedFragment (Header blk) (LedgerState blk)
-> AnchoredFragment (Header blk)
forall b l. ValidatedFragment b l -> AnchoredFragment b
VF.validatedFragment ValidatedFragment (Header blk) (LedgerState blk)
validated)
}
where
checkFragment :: HF.Summary (HardForkIndices blk)
-> RelativeTime
-> AnchoredFragment (Header blk)
-> (AnchoredFragment (Header blk), [InFuture m blk])
checkFragment :: Summary (HardForkIndices blk)
-> RelativeTime
-> AnchoredFragment (Header blk)
-> (AnchoredFragment (Header blk), [InFuture m blk])
checkFragment Summary (HardForkIndices blk)
summary RelativeTime
now = AnchoredFragment (Header blk)
-> (AnchoredFragment (Header blk), [InFuture m blk])
go
where
go :: AnchoredFragment (Header blk)
-> (AnchoredFragment (Header blk), [InFuture m blk])
go :: AnchoredFragment (Header blk)
-> (AnchoredFragment (Header blk), [InFuture m blk])
go (Empty Anchor (Header blk)
a) = (Anchor (Header blk) -> AnchoredFragment (Header blk)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
Empty Anchor (Header blk)
a, [])
go (AnchoredFragment (Header blk)
hs :> Header blk
h) =
case Qry (RelativeTime, SlotLength)
-> Summary (HardForkIndices blk)
-> Either PastHorizonException (RelativeTime, SlotLength)
forall a (xs :: [*]).
HasCallStack =>
Qry a -> Summary xs -> Either PastHorizonException a
HF.runQuery
(SlotNo -> Qry (RelativeTime, SlotLength)
HF.slotToWallclock (Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
h))
Summary (HardForkIndices blk)
summary of
Left PastHorizonException
_err ->
String -> (AnchoredFragment (Header blk), [InFuture m blk])
forall a. HasCallStack => String -> a
error String
"CheckInFuture.reference: impossible"
Right (RelativeTime
hdrTime, SlotLength
_) ->
if RelativeTime
hdrTime RelativeTime -> RelativeTime -> Bool
forall a. Ord a => a -> a -> Bool
> RelativeTime
now then
([InFuture m blk] -> [InFuture m blk])
-> (AnchoredFragment (Header blk), [InFuture m blk])
-> (AnchoredFragment (Header blk), [InFuture m blk])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Header blk -> RelativeTime -> InFuture m blk
inFuture Header blk
h RelativeTime
hdrTimeInFuture m blk -> [InFuture m blk] -> [InFuture m blk]
forall a. a -> [a] -> [a]
:) ((AnchoredFragment (Header blk), [InFuture m blk])
-> (AnchoredFragment (Header blk), [InFuture m blk]))
-> (AnchoredFragment (Header blk), [InFuture m blk])
-> (AnchoredFragment (Header blk), [InFuture m blk])
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk)
-> (AnchoredFragment (Header blk), [InFuture m blk])
go AnchoredFragment (Header blk)
hs
else
(AnchoredFragment (Header blk)
hs AnchoredFragment (Header blk)
-> Header blk -> AnchoredFragment (Header blk)
forall v a b.
Anchorable v a b =>
AnchoredSeq v a b -> b -> AnchoredSeq v a b
:> Header blk
h, [])
inFuture :: Header blk -> RelativeTime -> InFuture m blk
inFuture :: Header blk -> RelativeTime -> InFuture m blk
inFuture Header blk
hdr RelativeTime
hdrTime = InFuture {
inFutureHeader :: Header blk
inFutureHeader = Header blk
hdr
, inFutureExceedsClockSkew :: Bool
inFutureExceedsClockSkew = (RelativeTime
hdrTime RelativeTime -> RelativeTime -> NominalDiffTime
`diffRelTime` RelativeTime
now)
NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> NominalDiffTime
clockSkew
, inFuturePunish :: InvalidBlockPunishment m
inFuturePunish = InvalidBlockPunishment m
forall (m :: * -> *). Applicative m => InvalidBlockPunishment m
InvalidBlockPunishment.noPunishment
}
dontCheck :: Monad m => CheckInFuture m blk
dontCheck :: forall (m :: * -> *) blk. Monad m => CheckInFuture m blk
dontCheck = CheckInFuture {
checkInFuture :: ValidatedFragment (Header blk) (LedgerState blk)
-> m (AnchoredFragment (Header blk), [InFuture m blk])
checkInFuture = \ValidatedFragment (Header blk) (LedgerState blk)
validated -> (AnchoredFragment (Header blk), [InFuture m blk])
-> m (AnchoredFragment (Header blk), [InFuture m blk])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ValidatedFragment (Header blk) (LedgerState blk)
-> AnchoredFragment (Header blk)
forall b l. ValidatedFragment b l -> AnchoredFragment b
VF.validatedFragment ValidatedFragment (Header blk) (LedgerState blk)
validated, [])
}
miracle :: forall m blk. (MonadSTM m, HasHeader (Header blk))
=> STM m SlotNo
-> Word64
-> CheckInFuture m blk
miracle :: forall (m :: * -> *) blk.
(MonadSTM m, HasHeader (Header blk)) =>
STM m SlotNo -> Word64 -> CheckInFuture m blk
miracle STM m SlotNo
oracle Word64
clockSkew = CheckInFuture {
checkInFuture :: ValidatedFragment (Header blk) (LedgerState blk)
-> m (AnchoredFragment (Header blk), [InFuture m blk])
checkInFuture = \ValidatedFragment (Header blk) (LedgerState blk)
validated -> do
SlotNo
now <- STM m SlotNo -> m SlotNo
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m SlotNo -> m SlotNo) -> STM m SlotNo -> m SlotNo
forall a b. (a -> b) -> a -> b
$ STM m SlotNo
oracle
(AnchoredFragment (Header blk), [InFuture m blk])
-> m (AnchoredFragment (Header blk), [InFuture m blk])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((AnchoredFragment (Header blk), [InFuture m blk])
-> m (AnchoredFragment (Header blk), [InFuture m blk]))
-> (AnchoredFragment (Header blk), [InFuture m blk])
-> m (AnchoredFragment (Header blk), [InFuture m blk])
forall a b. (a -> b) -> a -> b
$ SlotNo
-> AnchoredFragment (Header blk)
-> (AnchoredFragment (Header blk), [InFuture m blk])
checkFragment SlotNo
now (ValidatedFragment (Header blk) (LedgerState blk)
-> AnchoredFragment (Header blk)
forall b l. ValidatedFragment b l -> AnchoredFragment b
VF.validatedFragment ValidatedFragment (Header blk) (LedgerState blk)
validated)
}
where
checkFragment :: SlotNo
-> AnchoredFragment (Header blk)
-> (AnchoredFragment (Header blk), [InFuture m blk])
checkFragment :: SlotNo
-> AnchoredFragment (Header blk)
-> (AnchoredFragment (Header blk), [InFuture m blk])
checkFragment SlotNo
now = AnchoredFragment (Header blk)
-> (AnchoredFragment (Header blk), [InFuture m blk])
go
where
go :: AnchoredFragment (Header blk)
-> (AnchoredFragment (Header blk), [InFuture m blk])
go :: AnchoredFragment (Header blk)
-> (AnchoredFragment (Header blk), [InFuture m blk])
go (Empty Anchor (Header blk)
a) = (Anchor (Header blk) -> AnchoredFragment (Header blk)
forall v a b. Anchorable v a b => a -> AnchoredSeq v a b
Empty Anchor (Header blk)
a, [])
go (AnchoredFragment (Header blk)
hs :> Header blk
h) =
if Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
h SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
> SlotNo
now then
([InFuture m blk] -> [InFuture m blk])
-> (AnchoredFragment (Header blk), [InFuture m blk])
-> (AnchoredFragment (Header blk), [InFuture m blk])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (Header blk -> InFuture m blk
inFuture Header blk
hInFuture m blk -> [InFuture m blk] -> [InFuture m blk]
forall a. a -> [a] -> [a]
:) ((AnchoredFragment (Header blk), [InFuture m blk])
-> (AnchoredFragment (Header blk), [InFuture m blk]))
-> (AnchoredFragment (Header blk), [InFuture m blk])
-> (AnchoredFragment (Header blk), [InFuture m blk])
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk)
-> (AnchoredFragment (Header blk), [InFuture m blk])
go AnchoredFragment (Header blk)
hs
else
(AnchoredFragment (Header blk)
hs AnchoredFragment (Header blk)
-> Header blk -> AnchoredFragment (Header blk)
forall v a b.
Anchorable v a b =>
AnchoredSeq v a b -> b -> AnchoredSeq v a b
:> Header blk
h, [])
inFuture :: Header blk -> InFuture m blk
inFuture :: Header blk -> InFuture m blk
inFuture Header blk
hdr = InFuture {
inFutureHeader :: Header blk
inFutureHeader = Header blk
hdr
, inFutureExceedsClockSkew :: Bool
inFutureExceedsClockSkew = HasCallStack => SlotNo -> SlotNo -> Word64
SlotNo -> SlotNo -> Word64
HF.countSlots (Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr) SlotNo
now
Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
clockSkew
, inFuturePunish :: InvalidBlockPunishment m
inFuturePunish = InvalidBlockPunishment m
forall (m :: * -> *). Applicative m => InvalidBlockPunishment m
InvalidBlockPunishment.noPunishment
}