{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}

module Ouroboros.Consensus.Shelley.Protocol.EnvelopeChecks
  ( EnvelopeError (..)
  , EnvelopeHeaderView (..)
  , envelopeCheck
  ) where

import Cardano.Ledger.BaseTypes (Version)
import Cardano.Ledger.Chain (ChainChecksPParams (ccMaxBBSize, ccMaxBHSize))
import Control.Monad (unless)
import Control.Monad.Except (Except, throwError)
import Data.Word (Word16, Word32)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)

data EnvelopeError
  = -- | This is a subtle case.
    --
    -- This node is explicitly rejecting the header, but the header isn't
    -- necessarily _directly_ at fault.
    --
    -- This rejection specifically happens when the ticked ledger state being
    -- used to validate this header contains a protocol major version (the
    -- first 'Version') that exceeds the maximum major protocol version allowed
    -- for this era this specific node's configuration (the second 'Version').
    -- The only thing the header did "wrong" was extend such a ledger state.
    --
    -- Note that the ChainSync client ensures that that ledger state is ticked
    -- starting from one of the latest k+1 ledger states on the node's current
    -- chain (modulo STM scheduling).
    --
    -- For Cardano and for now at least, this max major prot ver is typically
    -- hardcoded in the source code (subject only to whether or not the
    -- run-time config files enable "experimental" eras).
    --
    -- Hence, most likely, the appropriate rectifying action is for the node
    -- operator to update their node software and/or config; hence the name
    -- 'ObsoleteNode'. (Or if they're intentionally testing an experimental
    -- era, they forgot to set the appropriate config flag.)
    --
    -- TODO Would it be more intuitive to instead enforce this when validating
    -- the block that results in a ledger state with a major prot ver that
    -- violates the config's limit? Would the errors the user sees be more or
    -- less helpful? Etc.
    --
    -- TODO (cont'd) It's not even obviously that specific ledger
    -- state's/block's fault, since the protocol version is the consequence of
    -- on-chain governance. Is it the voters' fault? Is the fault of the first
    -- block that was after the voting deadline? So "extending the ledger state
    -- that resulting from ticking after applying the block after the epoch
    -- that extended the ancestor block that was after the voting deadline that
    -- ..." is merely one step more removed. And this 'envelopeChecks' approach
    -- does avoid the surprise (since the rejection doesn't even depend on the
    -- block's non-header content either) where the header could be validated
    -- but its underlying block could not. See
    -- <https://github.com/IntersectMBO/ouroboros-consensus/issues/325>.
    ObsoleteNode !Version !Version
  | HeaderSizeTooLarge !Int !Word16
  | BlockSizeTooLarge !Word32 !Word32
  deriving (EnvelopeError -> EnvelopeError -> Bool
(EnvelopeError -> EnvelopeError -> Bool)
-> (EnvelopeError -> EnvelopeError -> Bool) -> Eq EnvelopeError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EnvelopeError -> EnvelopeError -> Bool
== :: EnvelopeError -> EnvelopeError -> Bool
$c/= :: EnvelopeError -> EnvelopeError -> Bool
/= :: EnvelopeError -> EnvelopeError -> Bool
Eq, (forall x. EnvelopeError -> Rep EnvelopeError x)
-> (forall x. Rep EnvelopeError x -> EnvelopeError)
-> Generic EnvelopeError
forall x. Rep EnvelopeError x -> EnvelopeError
forall x. EnvelopeError -> Rep EnvelopeError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. EnvelopeError -> Rep EnvelopeError x
from :: forall x. EnvelopeError -> Rep EnvelopeError x
$cto :: forall x. Rep EnvelopeError x -> EnvelopeError
to :: forall x. Rep EnvelopeError x -> EnvelopeError
Generic, Int -> EnvelopeError -> ShowS
[EnvelopeError] -> ShowS
EnvelopeError -> String
(Int -> EnvelopeError -> ShowS)
-> (EnvelopeError -> String)
-> ([EnvelopeError] -> ShowS)
-> Show EnvelopeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EnvelopeError -> ShowS
showsPrec :: Int -> EnvelopeError -> ShowS
$cshow :: EnvelopeError -> String
show :: EnvelopeError -> String
$cshowList :: [EnvelopeError] -> ShowS
showList :: [EnvelopeError] -> ShowS
Show)

instance NoThunks EnvelopeError

data EnvelopeHeaderView = EnvelopeHeaderView
  { EnvelopeHeaderView -> Version
ehvProtVer :: !Version
  -- ^ The version against which to compare the node's max.
  , EnvelopeHeaderView -> Int
ehvHeaderSize :: !Int
  , EnvelopeHeaderView -> Word32
ehvBodySize :: !Word32
  }

-- | Shared envelope-check logic between Praos and TPraos.
--   'ehvProtVer' is the block header declared protocol version in TPraos, and
--   the ledger view's protocol version in Praos - see docs for EnvelopeError
envelopeCheck ::
  Version ->
  ChainChecksPParams ->
  EnvelopeHeaderView ->
  Except EnvelopeError ()
envelopeCheck :: Version
-> ChainChecksPParams
-> EnvelopeHeaderView
-> Except EnvelopeError ()
envelopeCheck Version
maxpv ChainChecksPParams
ccd EnvelopeHeaderView{Version
ehvProtVer :: EnvelopeHeaderView -> Version
ehvProtVer :: Version
ehvProtVer, Int
ehvHeaderSize :: EnvelopeHeaderView -> Int
ehvHeaderSize :: Int
ehvHeaderSize, Word32
ehvBodySize :: EnvelopeHeaderView -> Word32
ehvBodySize :: Word32
ehvBodySize} = do
  Bool -> Except EnvelopeError () -> Except EnvelopeError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version
ehvProtVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
<= Version
maxpv) (Except EnvelopeError () -> Except EnvelopeError ())
-> Except EnvelopeError () -> Except EnvelopeError ()
forall a b. (a -> b) -> a -> b
$
    EnvelopeError -> Except EnvelopeError ()
forall a. EnvelopeError -> ExceptT EnvelopeError Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EnvelopeError -> Except EnvelopeError ())
-> EnvelopeError -> Except EnvelopeError ()
forall a b. (a -> b) -> a -> b
$
      Version -> Version -> EnvelopeError
ObsoleteNode Version
ehvProtVer Version
maxpv
  Bool -> Except EnvelopeError () -> Except EnvelopeError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
ehvHeaderSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word16 @Int (ChainChecksPParams -> Word16
ccMaxBHSize ChainChecksPParams
ccd)) (Except EnvelopeError () -> Except EnvelopeError ())
-> Except EnvelopeError () -> Except EnvelopeError ()
forall a b. (a -> b) -> a -> b
$
    EnvelopeError -> Except EnvelopeError ()
forall a. EnvelopeError -> ExceptT EnvelopeError Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EnvelopeError -> Except EnvelopeError ())
-> EnvelopeError -> Except EnvelopeError ()
forall a b. (a -> b) -> a -> b
$
      Int -> Word16 -> EnvelopeError
HeaderSizeTooLarge Int
ehvHeaderSize (ChainChecksPParams -> Word16
ccMaxBHSize ChainChecksPParams
ccd)
  Bool -> Except EnvelopeError () -> Except EnvelopeError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
ehvBodySize Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<= ChainChecksPParams -> Word32
ccMaxBBSize ChainChecksPParams
ccd) (Except EnvelopeError () -> Except EnvelopeError ())
-> Except EnvelopeError () -> Except EnvelopeError ()
forall a b. (a -> b) -> a -> b
$
    EnvelopeError -> Except EnvelopeError ()
forall a. EnvelopeError -> ExceptT EnvelopeError Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (EnvelopeError -> Except EnvelopeError ())
-> EnvelopeError -> Except EnvelopeError ()
forall a b. (a -> b) -> a -> b
$
      Word32 -> Word32 -> EnvelopeError
BlockSizeTooLarge Word32
ehvBodySize (ChainChecksPParams -> Word32
ccMaxBBSize ChainChecksPParams
ccd)