{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Intended for qualified import
--
-- > import Ouroboros.Consensus.Fragment.InFuture (CheckInFuture(..), ClockSkew(..))
-- > import qualified Ouroboros.Consensus.Fragment.InFuture as InFuture
module Ouroboros.Consensus.Fragment.InFuture (
    CheckInFuture (..)
  , InFuture (..)
  , reference
    -- * Clock skew
  , clockSkewInSeconds
  , defaultClockSkew
    -- ** not exporting the constructor
  , ClockSkew
  , unClockSkew
    -- * Testing
  , 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 {
       -- | POSTCONDITION:
       --
       -- > checkInFuture vf >>= \(af, fut) ->
       -- >   validatedFragment vf == af <=> null fut
       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)

-- | Header of block that we found to be in the future
data InFuture m blk = InFuture {
      -- | The header itself
      forall (m :: * -> *) blk. InFuture m blk -> Header blk
inFutureHeader           :: Header blk

      -- | Whether or not this header exceeded the allowed clock skew
      --
      -- Headers that do exceed the clock skew should be considered invalid.
    , forall (m :: * -> *) blk. InFuture m blk -> Bool
inFutureExceedsClockSkew :: Bool

      -- | 'Ouroboros.Consensus.Storage.ChainDB.Impl.Types.blockPunish'
    , forall (m :: * -> *) blk.
InFuture m blk -> InvalidBlockPunishment m
inFuturePunish           :: InvalidBlockPunishment m
    }

{-------------------------------------------------------------------------------
  Clock skew
-------------------------------------------------------------------------------}

-- | Maximum permissible clock skew
--
-- When running NTP, systems clocks will never be perfectly synchronized. The
-- maximum clock skew records how much of a difference we consider acceptable.
--
-- For example. Suppose
--
-- * Two nodes A and B
-- * A's clock is 0.5 ahead of B's
-- * A produces a block and sends it to B
-- * When B translates the 'SlotNo' of that block to a time, it may find that
--   it is 0.5 seconds ahead of its current clock (worst case).
--
-- The maximum permissible clock skew decides if B will consider this block to
-- be valid (even if it will not yet consider it for chain seleciton) or as
-- invalid (and disconnect from A, since A is sending it invalid blocks).
--
-- Use 'defaultClockSkew' when unsure.
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)

-- | Default maximum permissible clock skew
--
-- See 'ClockSkew' for details. We allow for 2 seconds skew by default.
defaultClockSkew :: ClockSkew
defaultClockSkew :: ClockSkew
defaultClockSkew = Double -> ClockSkew
clockSkewInSeconds Double
2

-- | Specify maximum clock skew in seconds
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 implementation
-------------------------------------------------------------------------------}

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
        -- Since we have the ledger state /after/ the fragment, the derived
        -- summary can be used to check all of the blocks in the fragment
        (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
        -- We work from newest to oldest, because as soon as we reach any block
        -- that is not ahead of @no@, the older blocks certainly aren't either.
        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
            }

{-------------------------------------------------------------------------------
  Test infrastructure
-------------------------------------------------------------------------------}

-- | Trivial 'InFuture' check that doesn't do any check at all
--
-- This is useful for testing and tools such as the DB converter.
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, [])
    }

-- | If by some miracle we have a function that can always tell us what the
-- correct slot is, implementing 'CheckInFuture' is easy
--
-- NOTE: Use of 'miracle' in tests means that none of the hard fork
-- infrastructure for converting slots to time is tested.
miracle :: forall m blk. (MonadSTM m, HasHeader (Header blk))
        => STM m SlotNo          -- ^ Get current slot
        -> Word64                -- ^ Maximum clock skew (in terms of slots)
        -> 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
            }