{-# 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.BHeaderView (BHeaderView (..))
import Cardano.Ledger.BaseTypes (ProtVer (..), Version)
import Cardano.Ledger.Core
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 (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, 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)

instance NoThunks ChainPredicateFailure

chainChecks ::
  MonadError ChainPredicateFailure m =>
  Version ->
  ChainChecksPParams ->
  BHeaderView ->
  m ()
chainChecks :: forall (m :: * -> *).
MonadError ChainPredicateFailure m =>
Version -> ChainChecksPParams -> BHeaderView -> m ()
chainChecks Version
maxpv ChainChecksPParams
ccd BHeaderView
bhv = 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)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BHeaderView -> Int
bhviewHSize BHeaderView
bhv 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 (BHeaderView -> Int
bhviewHSize BHeaderView
bhv) (ChainChecksPParams -> Word16
ccMaxBHSize ChainChecksPParams
ccd)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BHeaderView -> Word32
bhviewBSize BHeaderView
bhv 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 (BHeaderView -> Word32
bhviewBSize BHeaderView
bhv) (ChainChecksPParams -> Word32
ccMaxBBSize ChainChecksPParams
ccd)
  where
    ProtVer Version
m Natural
_ = ChainChecksPParams -> ProtVer
ccProtocolVersion ChainChecksPParams
ccd