{-# 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainChecksPParams] -> ShowS
$cshowList :: [ChainChecksPParams] -> ShowS
show :: ChainChecksPParams -> String
$cshow :: ChainChecksPParams -> String
showsPrec :: Int -> ChainChecksPParams -> ShowS
$cshowsPrec :: Int -> ChainChecksPParams -> ShowS
Show, ChainChecksPParams -> ChainChecksPParams -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainChecksPParams -> ChainChecksPParams -> Bool
$c/= :: ChainChecksPParams -> ChainChecksPParams -> Bool
== :: ChainChecksPParams -> ChainChecksPParams -> Bool
$c== :: ChainChecksPParams -> ChainChecksPParams -> Bool
Eq, 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
$cto :: forall x. Rep ChainChecksPParams x -> ChainChecksPParams
$cfrom :: forall x. ChainChecksPParams -> Rep ChainChecksPParams x
Generic, Context -> ChainChecksPParams -> IO (Maybe ThunkInfo)
Proxy ChainChecksPParams -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy ChainChecksPParams -> String
$cshowTypeOf :: Proxy ChainChecksPParams -> String
wNoThunks :: Context -> ChainChecksPParams -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> ChainChecksPParams -> IO (Maybe ThunkInfo)
noThunks :: Context -> ChainChecksPParams -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> ChainChecksPParams -> IO (Maybe ThunkInfo)
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 forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Word16
ppMaxBHSizeL
    , ccMaxBBSize :: Word32
ccMaxBBSize = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Word32
ppMaxBBSizeL
    , ccProtocolVersion :: ProtVer
ccProtocolVersion = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => 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. 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
$cto :: forall x. Rep ChainPredicateFailure x -> ChainPredicateFailure
$cfrom :: forall x. ChainPredicateFailure -> Rep ChainPredicateFailure x
Generic, Int -> ChainPredicateFailure -> ShowS
[ChainPredicateFailure] -> ShowS
ChainPredicateFailure -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ChainPredicateFailure] -> ShowS
$cshowList :: [ChainPredicateFailure] -> ShowS
show :: ChainPredicateFailure -> String
$cshow :: ChainPredicateFailure -> String
showsPrec :: Int -> ChainPredicateFailure -> ShowS
$cshowsPrec :: Int -> ChainPredicateFailure -> ShowS
Show, ChainPredicateFailure -> ChainPredicateFailure -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
$c/= :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
== :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
$c== :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
Eq, Eq 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
min :: ChainPredicateFailure
-> ChainPredicateFailure -> ChainPredicateFailure
$cmin :: ChainPredicateFailure
-> ChainPredicateFailure -> ChainPredicateFailure
max :: ChainPredicateFailure
-> ChainPredicateFailure -> ChainPredicateFailure
$cmax :: ChainPredicateFailure
-> ChainPredicateFailure -> ChainPredicateFailure
>= :: ChainPredicateFailure -> ChainPredicateFailure -> Bool
$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
compare :: ChainPredicateFailure -> ChainPredicateFailure -> Ordering
$ccompare :: ChainPredicateFailure -> ChainPredicateFailure -> Ordering
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
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version
m forall a. Ord a => a -> a -> Bool
<= Version
maxpv) forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Version -> Version -> ChainPredicateFailure
ObsoleteNodeCHAIN Version
m Version
maxpv)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BHeaderView -> Int
bhviewHSize BHeaderView
bhv forall a. Ord a => a -> a -> Bool
<= (forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Word16 -> Int) (ChainChecksPParams -> Word16
ccMaxBHSize ChainChecksPParams
ccd)) forall a b. (a -> b) -> a -> b
$
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
      Int -> Word16 -> ChainPredicateFailure
HeaderSizeTooLargeCHAIN (BHeaderView -> Int
bhviewHSize BHeaderView
bhv) (ChainChecksPParams -> Word16
ccMaxBHSize ChainChecksPParams
ccd)
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BHeaderView -> Word32
bhviewBSize BHeaderView
bhv forall a. Ord a => a -> a -> Bool
<= ChainChecksPParams -> Word32
ccMaxBBSize ChainChecksPParams
ccd) forall a b. (a -> b) -> a -> b
$
    forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError 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