{-# 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           Ouroboros.Consensus.Config (TopLevelConfig)
import           Ouroboros.Consensus.Config.SecurityParam

-- | An issue found in the 'TopLevelConfig' for a block. 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)
  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)
      ]

-- | '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]