{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.Chain (
  -- | Chain Checks
  ChainChecksPParams (..),
  ChainPredicateFailure (..),
  pparamsToChainChecksPParams,
  chainChecks,
) where

import Cardano.Ledger.BaseTypes (ProtVer (..), Version)
import Cardano.Ledger.Block (Block, EraBlockHeader (..))
import Cardano.Ledger.Core
import Control.DeepSeq (NFData)
import Control.Monad (unless)
import Control.Monad.Except (MonadError, throwError)
import Data.Word (Word16, Word32)
import GHC.Generics (Generic)
import Lens.Micro ((^.))
import NoThunks.Class (NoThunks (..))

data ChainChecksPParams = ChainChecksPParams
  { ChainChecksPParams -> Word16
ccMaxBHSize :: Word16
  , ChainChecksPParams -> Word32
ccMaxBBSize :: Word32
  , ChainChecksPParams -> ProtVer
ccProtocolVersion :: ProtVer
  }
  deriving stock (Int -> ChainChecksPParams -> ShowS
[ChainChecksPParams] -> ShowS
ChainChecksPParams -> String
(Int -> ChainChecksPParams -> ShowS)
-> (ChainChecksPParams -> String)
-> ([ChainChecksPParams] -> ShowS)
-> Show ChainChecksPParams
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainChecksPParams -> ShowS
showsPrec :: Int -> ChainChecksPParams -> ShowS
$cshow :: ChainChecksPParams -> String
show :: ChainChecksPParams -> String
$cshowList :: [ChainChecksPParams] -> ShowS
showList :: [ChainChecksPParams] -> ShowS
Show, ChainChecksPParams -> ChainChecksPParams -> Bool
(ChainChecksPParams -> ChainChecksPParams -> Bool)
-> (ChainChecksPParams -> ChainChecksPParams -> Bool)
-> Eq ChainChecksPParams
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainChecksPParams -> ChainChecksPParams -> Bool
== :: ChainChecksPParams -> ChainChecksPParams -> Bool
$c/= :: ChainChecksPParams -> ChainChecksPParams -> Bool
/= :: ChainChecksPParams -> ChainChecksPParams -> Bool
Eq, (forall x. ChainChecksPParams -> Rep ChainChecksPParams x)
-> (forall x. Rep ChainChecksPParams x -> ChainChecksPParams)
-> Generic ChainChecksPParams
forall x. Rep ChainChecksPParams x -> ChainChecksPParams
forall x. ChainChecksPParams -> Rep ChainChecksPParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChainChecksPParams -> Rep ChainChecksPParams x
from :: forall x. ChainChecksPParams -> Rep ChainChecksPParams x
$cto :: forall x. Rep ChainChecksPParams x -> ChainChecksPParams
to :: forall x. Rep ChainChecksPParams x -> ChainChecksPParams
Generic)
  deriving anyclass (ChainChecksPParams -> ()
(ChainChecksPParams -> ()) -> NFData ChainChecksPParams
forall a. (a -> ()) -> NFData a
$crnf :: ChainChecksPParams -> ()
rnf :: ChainChecksPParams -> ()
NFData, Context -> ChainChecksPParams -> IO (Maybe ThunkInfo)
Proxy ChainChecksPParams -> String
(Context -> ChainChecksPParams -> IO (Maybe ThunkInfo))
-> (Context -> ChainChecksPParams -> IO (Maybe ThunkInfo))
-> (Proxy ChainChecksPParams -> String)
-> NoThunks ChainChecksPParams
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> ChainChecksPParams -> IO (Maybe ThunkInfo)
noThunks :: Context -> ChainChecksPParams -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ChainChecksPParams -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> ChainChecksPParams -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy ChainChecksPParams -> String
showTypeOf :: Proxy ChainChecksPParams -> String
NoThunks)

pparamsToChainChecksPParams ::
  EraPParams era =>
  PParams era ->
  ChainChecksPParams
pparamsToChainChecksPParams :: forall era. EraPParams era => PParams era -> ChainChecksPParams
pparamsToChainChecksPParams PParams era
pp =
  ChainChecksPParams
    { ccMaxBHSize :: Word16
ccMaxBHSize = PParams era
pp PParams era -> Getting Word16 (PParams era) Word16 -> Word16
forall s a. s -> Getting a s a -> a
^. Getting Word16 (PParams era) Word16
forall era. EraPParams era => Lens' (PParams era) Word16
Lens' (PParams era) Word16
ppMaxBHSizeL
    , ccMaxBBSize :: Word32
ccMaxBBSize = PParams era
pp PParams era -> Getting Word32 (PParams era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (PParams era) Word32
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams era) Word32
ppMaxBBSizeL
    , ccProtocolVersion :: ProtVer
ccProtocolVersion = PParams era
pp PParams era -> Getting ProtVer (PParams era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. Getting ProtVer (PParams era) ProtVer
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
ppProtocolVersionL
    }

data ChainPredicateFailure
  = HeaderSizeTooLargeCHAIN
      Int -- Header Size
      Word16 -- Max Header Size
  | BlockSizeTooLargeCHAIN
      Word32 -- Block Size
      Word32 -- Max Block Size
  | ObsoleteNodeCHAIN
      Version -- protocol version used
      Version -- max protocol version
  deriving ((forall x. ChainPredicateFailure -> Rep ChainPredicateFailure x)
-> (forall x. Rep ChainPredicateFailure x -> ChainPredicateFailure)
-> Generic ChainPredicateFailure
forall x. Rep ChainPredicateFailure x -> ChainPredicateFailure
forall x. ChainPredicateFailure -> Rep ChainPredicateFailure x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChainPredicateFailure -> Rep ChainPredicateFailure x
from :: forall x. ChainPredicateFailure -> Rep ChainPredicateFailure x
$cto :: forall x. Rep ChainPredicateFailure x -> ChainPredicateFailure
to :: forall x. Rep ChainPredicateFailure x -> ChainPredicateFailure
Generic, Int -> ChainPredicateFailure -> ShowS
[ChainPredicateFailure] -> ShowS
ChainPredicateFailure -> String
(Int -> ChainPredicateFailure -> ShowS)
-> (ChainPredicateFailure -> String)
-> ([ChainPredicateFailure] -> ShowS)
-> Show ChainPredicateFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ChainPredicateFailure -> ShowS
showsPrec :: Int -> ChainPredicateFailure -> ShowS
$cshow :: ChainPredicateFailure -> String
show :: ChainPredicateFailure -> String
$cshowList :: [ChainPredicateFailure] -> ShowS
showList :: [ChainPredicateFailure] -> ShowS
Show, ChainPredicateFailure -> ChainPredicateFailure -> Bool
(ChainPredicateFailure -> ChainPredicateFailure -> Bool)
-> (ChainPredicateFailure -> ChainPredicateFailure -> Bool)
-> Eq ChainPredicateFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
== :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
$c/= :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
/= :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
Eq, Eq ChainPredicateFailure
Eq ChainPredicateFailure =>
(ChainPredicateFailure -> ChainPredicateFailure -> Ordering)
-> (ChainPredicateFailure -> ChainPredicateFailure -> Bool)
-> (ChainPredicateFailure -> ChainPredicateFailure -> Bool)
-> (ChainPredicateFailure -> ChainPredicateFailure -> Bool)
-> (ChainPredicateFailure -> ChainPredicateFailure -> Bool)
-> (ChainPredicateFailure
    -> ChainPredicateFailure -> ChainPredicateFailure)
-> (ChainPredicateFailure
    -> ChainPredicateFailure -> ChainPredicateFailure)
-> Ord ChainPredicateFailure
ChainPredicateFailure -> ChainPredicateFailure -> Bool
ChainPredicateFailure -> ChainPredicateFailure -> Ordering
ChainPredicateFailure
-> ChainPredicateFailure -> ChainPredicateFailure
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 :: ChainPredicateFailure -> ChainPredicateFailure -> Ordering
compare :: ChainPredicateFailure -> ChainPredicateFailure -> Ordering
$c< :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
< :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
$c<= :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
<= :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
$c> :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
> :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
$c>= :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
>= :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
$cmax :: ChainPredicateFailure
-> ChainPredicateFailure -> ChainPredicateFailure
max :: ChainPredicateFailure
-> ChainPredicateFailure -> ChainPredicateFailure
$cmin :: ChainPredicateFailure
-> ChainPredicateFailure -> ChainPredicateFailure
min :: ChainPredicateFailure
-> ChainPredicateFailure -> ChainPredicateFailure
Ord)

chainChecks ::
  (MonadError ChainPredicateFailure m, EraBlockHeader h era) =>
  Version ->
  ChainChecksPParams ->
  Block h era ->
  m ()
chainChecks :: forall (m :: * -> *) h era.
(MonadError ChainPredicateFailure m, EraBlockHeader h era) =>
Version -> ChainChecksPParams -> Block h era -> m ()
chainChecks Version
maxpv ChainChecksPParams
ccd Block h era
blk = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version
m Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
<= Version
maxpv) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ChainPredicateFailure -> m ()
forall a. ChainPredicateFailure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Version -> Version -> ChainPredicateFailure
ObsoleteNodeCHAIN Version
m Version
maxpv)
  let bhHSize :: Int
bhHSize = Block h era
blk Block h era -> Getting Int (Block h era) Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int (Block h era) Int
SimpleGetter (Block h era) Int
forall h era.
EraBlockHeader h era =>
SimpleGetter (Block h era) Int
blockHeaderSizeBlockHeaderG
      bhBSize :: Word32
bhBSize = Block h era
blk Block h era -> Getting Word32 (Block h era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. Getting Word32 (Block h era) Word32
forall h era. EraBlockHeader h era => Lens' (Block h era) Word32
Lens' (Block h era) Word32
blockBodySizeBlockHeaderL
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
bhHSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= (Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Word16 -> Int) (ChainChecksPParams -> Word16
ccMaxBHSize ChainChecksPParams
ccd)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    ChainPredicateFailure -> m ()
forall a. ChainPredicateFailure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChainPredicateFailure -> m ()) -> ChainPredicateFailure -> m ()
forall a b. (a -> b) -> a -> b
$
      Int -> Word16 -> ChainPredicateFailure
HeaderSizeTooLargeCHAIN Int
bhHSize (ChainChecksPParams -> Word16
ccMaxBHSize ChainChecksPParams
ccd)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word32
bhBSize Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
<= ChainChecksPParams -> Word32
ccMaxBBSize ChainChecksPParams
ccd) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    ChainPredicateFailure -> m ()
forall a. ChainPredicateFailure -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChainPredicateFailure -> m ()) -> ChainPredicateFailure -> m ()
forall a b. (a -> b) -> a -> b
$
      Word32 -> Word32 -> ChainPredicateFailure
BlockSizeTooLargeCHAIN Word32
bhBSize (ChainChecksPParams -> Word32
ccMaxBBSize ChainChecksPParams
ccd)
  where
    ProtVer Version
m Natural
_ = ChainChecksPParams -> ProtVer
ccProtocolVersion ChainChecksPParams
ccd