{-# LANGUAGE LambdaCase #-}

-- | This module adds support for sanity checking consensus configuration
--   on node startup. These checks should primarily look for unusual
--   configuration choices that may point to an accidentally-misconfigured node
--   and quietly cause problems, rather than incoherent configurations that will
--   result in fatal errors at a later point.
--
--   While in most situations they can be handled as fatal issues, there are
--   situations when intentionally configuring a node "weirdly" can be useful,
--   and so the user should be able to opt out of the sanity checks at their
--   own peril.
module Ouroboros.Consensus.Block.SupportsSanityCheck
  ( BlockSupportsSanityCheck (..)
  , SanityCheckIssue (..)
  , checkSecurityParamConsistency
  , sanityCheckConfig
  ) where

import Control.Exception
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (catMaybes)
import Data.Time.Clock (DiffTime)
import Data.Word (Word64)
import Ouroboros.Consensus.Config (TopLevelConfig)
import Ouroboros.Consensus.Config.SecurityParam

-- | An issue found in the consensus configuration. See 'displayException'
--   for human-readable descriptions of each of these cases, especially when
--   presenting these to users.
data SanityCheckIssue
  = -- | Configuration contains multiple security parameters. This may cause
    --   strange behaviour around era boundaries.
    InconsistentSecurityParam (NonEmpty SecurityParam)
  | -- | The configured 'minimumDelay' in 'SnapshotDelayRange' is greater than
    --   'maximumDelay'. The random snapshot delay will be sampled from an
    --   inverted range, which is almost certainly a misconfiguration.
    SnapshotDelayRangeInverted
      -- | The configured minimumDelay (the larger value)
      !DiffTime
      -- | The configured maximumDelay (the smaller value)
      !DiffTime
  | -- | The configured 'minimumDelay' in 'SnapshotDelayRange' is negative.
    --   A negative delay has no meaningful interpretation.
    SnapshotDelayRangeNegativeMinimum
      -- | The negative minimumDelay
      !DiffTime
  | -- | The configured 'sfaRateLimit' is non-positive, which disables snapshot
    --   rate limiting entirely. Without a rate limit, snapshots may be taken
    --   very frequently during bulk sync, causing excessive disk I/O.
    SnapshotRateLimitDisabled
  | -- | The configured 'sfaRateLimit' exceeds 24 hours. At steady state, the
    --   node may go more than a day between snapshots, significantly increasing
    --   replay time after an unclean restart.
    SnapshotRateLimitSuspiciouslyLarge
      -- | The configured rate limit
      !DiffTime
  | -- | The configured number of on-disk snapshots to keep is zero. Snapshots
    --   will be written to disk and then immediately deleted, leaving nothing
    --   for crash recovery. The node will have to replay from genesis on every
    --   unclean restart.
    SnapshotNumZero
  | -- | The configured snapshot interval does not divide 432000 (the Cardano
    --   mainnet epoch length in slots). Snapshots will not land on epoch
    --   boundaries, breaking Mithril compatibility.
    SnapshotIntervalNotDivisorOfEpoch
      -- | The configured interval in slots
      !Word64
  deriving (Int -> SanityCheckIssue -> ShowS
[SanityCheckIssue] -> ShowS
SanityCheckIssue -> String
(Int -> SanityCheckIssue -> ShowS)
-> (SanityCheckIssue -> String)
-> ([SanityCheckIssue] -> ShowS)
-> Show SanityCheckIssue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SanityCheckIssue -> ShowS
showsPrec :: Int -> SanityCheckIssue -> ShowS
$cshow :: SanityCheckIssue -> String
show :: SanityCheckIssue -> String
$cshowList :: [SanityCheckIssue] -> ShowS
showList :: [SanityCheckIssue] -> ShowS
Show, SanityCheckIssue -> SanityCheckIssue -> Bool
(SanityCheckIssue -> SanityCheckIssue -> Bool)
-> (SanityCheckIssue -> SanityCheckIssue -> Bool)
-> Eq SanityCheckIssue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SanityCheckIssue -> SanityCheckIssue -> Bool
== :: SanityCheckIssue -> SanityCheckIssue -> Bool
$c/= :: SanityCheckIssue -> SanityCheckIssue -> Bool
/= :: SanityCheckIssue -> SanityCheckIssue -> Bool
Eq)

instance Exception SanityCheckIssue where
  displayException :: SanityCheckIssue -> String
displayException = \case
    InconsistentSecurityParam NonEmpty SecurityParam
ks ->
      [String] -> String
forall a. Monoid a => [a] -> a
mconcat
        [ String
"InconsistentSecurityParam: "
        , String
"SecurityParams (K) were found to be inconsistent between constituent "
        , String
"eras of a HardForkBlock: "
        , [SecurityParam] -> String
forall a. Show a => a -> String
show (NonEmpty SecurityParam -> [SecurityParam]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty SecurityParam
ks)
        ]
    SnapshotDelayRangeInverted DiffTime
mn DiffTime
mx ->
      [String] -> String
forall a. Monoid a => [a] -> a
mconcat
        [ String
"SnapshotDelayRangeInverted: "
        , String
"The configured snapshot delay range has minimumDelay ("
        , DiffTime -> String
forall a. Show a => a -> String
show DiffTime
mn
        , String
") greater than maximumDelay ("
        , DiffTime -> String
forall a. Show a => a -> String
show DiffTime
mx
        , String
"). The random snapshot delay will be sampled from an inverted range. "
        , String
"Please ensure minimumDelay <= maximumDelay in sfaDelaySnapshotRange."
        ]
    SnapshotDelayRangeNegativeMinimum DiffTime
mn ->
      [String] -> String
forall a. Monoid a => [a] -> a
mconcat
        [ String
"SnapshotDelayRangeNegativeMinimum: "
        , String
"The configured snapshot delay range has a negative minimumDelay: "
        , DiffTime -> String
forall a. Show a => a -> String
show DiffTime
mn
        , String
". A negative delay has no meaningful interpretation. "
        , String
"Please set minimumDelay to a non-negative value in sfaDelaySnapshotRange."
        ]
    SanityCheckIssue
SnapshotRateLimitDisabled ->
      [String] -> String
forall a. Monoid a => [a] -> a
mconcat
        [ String
"SnapshotRateLimitDisabled: "
        , String
"The configured sfaRateLimit is non-positive, which disables snapshot "
        , String
"rate limiting entirely. Without a rate limit, snapshots may be taken "
        , String
"very frequently during bulk sync, causing excessive disk I/O. "
        , String
"The default rate limit is 10 minutes."
        ]
    SnapshotRateLimitSuspiciouslyLarge DiffTime
rl ->
      [String] -> String
forall a. Monoid a => [a] -> a
mconcat
        [ String
"SnapshotRateLimitSuspiciouslyLarge: "
        , String
"The configured sfaRateLimit ("
        , DiffTime -> String
forall a. Show a => a -> String
show DiffTime
rl
        , String
") exceeds 24 hours. At steady state, the node may go more than a day "
        , String
"between snapshots, significantly increasing replay time after an "
        , String
"unclean restart. The default rate limit is 10 minutes."
        ]
    SanityCheckIssue
SnapshotNumZero ->
      [String] -> String
forall a. Monoid a => [a] -> a
mconcat
        [ String
"SnapshotNumZero: "
        , String
"The configured number of on-disk snapshots to keep (spaNum) is 0. "
        , String
"Snapshots will be written to disk and immediately deleted, leaving "
        , String
"nothing for crash recovery. The node will have to replay the chain "
        , String
"from genesis on every unclean restart. "
        , String
"Consider setting spaNum to at least 2 (the default)."
        ]
    SnapshotIntervalNotDivisorOfEpoch Word64
interval ->
      [String] -> String
forall a. Monoid a => [a] -> a
mconcat
        [ String
"SnapshotIntervalNotDivisorOfEpoch: "
        , String
"The configured sfaInterval ("
        , Word64 -> String
forall a. Show a => a -> String
show Word64
interval
        , String
" slots) does not evenly divide the Cardano mainnet epoch length "
        , String
"(432000 slots). Snapshots will not consistently land on epoch "
        , String
"boundaries, which breaks Mithril compatibility. "
        , String
"Consider using an interval that divides 432000 evenly, "
        , String
"such as 4320 (the default, = 2k for k=2160)."
        ]

-- | 'BlockSupportsSanityCheck' provides evidence that a block can be sanity
--   checked for common issues on node startup. 'sanityCheckConfig', which runs
--   performs each check and returns a list with each 'SanityCheckIssue' found,
--   should be preferred over using these methods directly.
class BlockSupportsSanityCheck blk where
  -- | Generate a 'NonEmpty' list of security parameters for a given block type.
  --   For individual eras' block types, this is simply a singleton list
  --   containing the chosen 'SecurityParam', but combined block types (i.e.
  --   the 'HardForkCombinator') will return all of their constituent eras'
  --   configurations' security parameters.
  configAllSecurityParams ::
    TopLevelConfig blk ->
    NonEmpty SecurityParam

-- | Check a 'TopLevelConfig' for any inconsistency in constituent choices for
--   'SecurityParam' (colloquially @k@). For a block type to be considered
--   "sane" in this regard, its configuration's security parameter as well as
--   all of its childrens' configurations (if applicable) should be the same.
checkSecurityParamConsistency ::
  BlockSupportsSanityCheck blk =>
  TopLevelConfig blk ->
  Maybe SanityCheckIssue
checkSecurityParamConsistency :: forall blk.
BlockSupportsSanityCheck blk =>
TopLevelConfig blk -> Maybe SanityCheckIssue
checkSecurityParamConsistency TopLevelConfig blk
cfg = do
  let allParams :: NonEmpty SecurityParam
allParams = TopLevelConfig blk -> NonEmpty SecurityParam
forall blk.
BlockSupportsSanityCheck blk =>
TopLevelConfig blk -> NonEmpty SecurityParam
configAllSecurityParams TopLevelConfig blk
cfg
  if NonEmpty SecurityParam -> Bool
forall a. Eq a => NonEmpty a -> Bool
allSame NonEmpty SecurityParam
allParams
    then Maybe SanityCheckIssue
forall a. Maybe a
Nothing
    else SanityCheckIssue -> Maybe SanityCheckIssue
forall a. a -> Maybe a
Just (NonEmpty SecurityParam -> SanityCheckIssue
InconsistentSecurityParam NonEmpty SecurityParam
allParams)

allSame :: Eq a => NonEmpty a -> Bool
allSame :: forall a. Eq a => NonEmpty a -> Bool
allSame (a
x :| [a]
xs) = (a -> Bool) -> [a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==) [a]
xs

-- | Run all supported sanity checks on a given 'TopLevelConfig'.
sanityCheckConfig ::
  BlockSupportsSanityCheck blk =>
  TopLevelConfig blk ->
  [SanityCheckIssue]
sanityCheckConfig :: forall blk.
BlockSupportsSanityCheck blk =>
TopLevelConfig blk -> [SanityCheckIssue]
sanityCheckConfig TopLevelConfig blk
cfg =
  [Maybe SanityCheckIssue] -> [SanityCheckIssue]
forall a. [Maybe a] -> [a]
catMaybes [TopLevelConfig blk -> Maybe SanityCheckIssue
forall blk.
BlockSupportsSanityCheck blk =>
TopLevelConfig blk -> Maybe SanityCheckIssue
checkSecurityParamConsistency TopLevelConfig blk
cfg]