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

-- | 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
    -- ** opaque
  , ClockSkew
    -- * Testing
  , dontCheck
  , miracle
  ) where

import           Data.Bifunctor
import           Data.Time (NominalDiffTime)
import           Data.Word
import           NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..))

import           Control.Monad.Class.MonadSTM

import           Ouroboros.Network.AnchoredFragment (AnchoredFragment,
                     AnchoredSeq (Empty, (:>)))

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

data CheckInFuture m blk = CheckInFuture {
       -- | POSTCONDITION:
       -- > checkInFuture vf >>= \(af, fut) ->
       -- >   validatedFragment vf == af <=> null fut
       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
showTypeOf :: Proxy (CheckInFuture m blk) -> String
$cshowTypeOf :: forall (m :: * -> *) blk. Proxy (CheckInFuture m blk) -> String
wNoThunks :: Context -> CheckInFuture m blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (m :: * -> *) blk.
Context -> CheckInFuture m blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> CheckInFuture m blk -> IO (Maybe ThunkInfo)
$cnoThunks :: forall (m :: * -> *) blk.
Context -> CheckInFuture m blk -> IO (Maybe ThunkInfo)
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
      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.
    , InFuture m blk -> Bool
inFutureExceedsClockSkew :: Bool

      -- | 'Ouroboros.Consensus.Storage.ChainDB.Impl.Types.blockPunish'
    , 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
showList :: [ClockSkew] -> ShowS
$cshowList :: [ClockSkew] -> ShowS
show :: ClockSkew -> String
$cshow :: ClockSkew -> String
showsPrec :: Int -> ClockSkew -> ShowS
$cshowsPrec :: Int -> ClockSkew -> ShowS
Show, ClockSkew -> ClockSkew -> Bool
(ClockSkew -> ClockSkew -> Bool)
-> (ClockSkew -> ClockSkew -> Bool) -> Eq ClockSkew
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ClockSkew -> ClockSkew -> Bool
$c/= :: ClockSkew -> ClockSkew -> Bool
== :: ClockSkew -> ClockSkew -> Bool
$c== :: 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
min :: ClockSkew -> ClockSkew -> ClockSkew
$cmin :: ClockSkew -> ClockSkew -> ClockSkew
max :: ClockSkew -> ClockSkew -> ClockSkew
$cmax :: ClockSkew -> ClockSkew -> ClockSkew
>= :: ClockSkew -> ClockSkew -> Bool
$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
compare :: ClockSkew -> ClockSkew -> Ordering
$ccompare :: ClockSkew -> ClockSkew -> Ordering
$cp1Ord :: Eq ClockSkew
Ord)

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

-- | 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 :: LedgerConfig blk
-> ClockSkew -> SystemTime m -> CheckInFuture m blk
reference LedgerConfig blk
cfg (ClockSkew NominalDiffTime
clockSkew) SystemTime{m ()
m RelativeTime
systemTimeWait :: forall (m :: * -> *). SystemTime m -> m ()
systemTimeCurrent :: forall (m :: * -> *). SystemTime m -> m RelativeTime
systemTimeWait :: m ()
systemTimeCurrent :: m RelativeTime
..} = CheckInFuture :: forall (m :: * -> *) blk.
(ValidatedFragment (Header blk) (LedgerState blk)
 -> m (AnchoredFragment (Header blk), [InFuture m blk]))
-> CheckInFuture m blk
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 (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 (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 :: forall (m :: * -> *) blk.
Header blk -> Bool -> InvalidBlockPunishment m -> InFuture m blk
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 :: CheckInFuture m blk
dontCheck = CheckInFuture :: forall (m :: * -> *) blk.
(ValidatedFragment (Header blk) (LedgerState blk)
 -> m (AnchoredFragment (Header blk), [InFuture m blk]))
-> CheckInFuture m blk
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 (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 :: STM m SlotNo -> Word64 -> CheckInFuture m blk
miracle STM m SlotNo
oracle Word64
clockSkew = CheckInFuture :: forall (m :: * -> *) blk.
(ValidatedFragment (Header blk) (LedgerState blk)
 -> m (AnchoredFragment (Header blk), [InFuture m blk]))
-> CheckInFuture m blk
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 (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 (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 (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 :: forall (m :: * -> *) blk.
Header blk -> Bool -> InvalidBlockPunishment m -> InFuture m blk
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
            }