{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# 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 (..))
import Control.Monad (unless)
import Control.Monad.Except (MonadError, throwError)
import GHC.Generics (Generic)
import GHC.Records
import NoThunks.Class (NoThunks (..))
import Numeric.Natural (Natural)

data ChainChecksPParams = ChainChecksPParams
  { ChainChecksPParams -> Natural
ccMaxBHSize :: Natural,
    ChainChecksPParams -> Natural
ccMaxBBSize :: Natural,
    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
showList :: [ChainChecksPParams] -> ShowS
$cshowList :: [ChainChecksPParams] -> ShowS
show :: ChainChecksPParams -> String
$cshow :: ChainChecksPParams -> String
showsPrec :: Int -> ChainChecksPParams -> ShowS
$cshowsPrec :: Int -> ChainChecksPParams -> ShowS
Show, ChainChecksPParams -> ChainChecksPParams -> Bool
(ChainChecksPParams -> ChainChecksPParams -> Bool)
-> (ChainChecksPParams -> ChainChecksPParams -> Bool)
-> Eq ChainChecksPParams
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. 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
$cto :: forall x. Rep ChainChecksPParams x -> ChainChecksPParams
$cfrom :: forall x. ChainChecksPParams -> Rep ChainChecksPParams x
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
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 ::
  ( HasField "_maxBHSize" pp Natural,
    HasField "_maxBBSize" pp Natural,
    HasField "_protocolVersion" pp ProtVer
  ) =>
  pp ->
  ChainChecksPParams
pparamsToChainChecksPParams :: pp -> ChainChecksPParams
pparamsToChainChecksPParams pp
pp =
  ChainChecksPParams :: Natural -> Natural -> ProtVer -> ChainChecksPParams
ChainChecksPParams
    { ccMaxBHSize :: Natural
ccMaxBHSize = pp -> Natural
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_maxBHSize" pp
pp,
      ccMaxBBSize :: Natural
ccMaxBBSize = pp -> Natural
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_maxBBSize" pp
pp,
      ccProtocolVersion :: ProtVer
ccProtocolVersion = pp -> ProtVer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_protocolVersion" pp
pp
    }

data ChainPredicateFailure
  = HeaderSizeTooLargeCHAIN
      !Natural -- Header Size
      !Natural -- Max Header Size
  | BlockSizeTooLargeCHAIN
      !Natural -- Block Size
      !Natural -- Max Block Size
  | ObsoleteNodeCHAIN
      !Natural -- protocol version used
      !Natural -- 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
$cto :: forall x. Rep ChainPredicateFailure x -> ChainPredicateFailure
$cfrom :: forall x. ChainPredicateFailure -> Rep ChainPredicateFailure x
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
showList :: [ChainPredicateFailure] -> ShowS
$cshowList :: [ChainPredicateFailure] -> ShowS
show :: ChainPredicateFailure -> String
$cshow :: ChainPredicateFailure -> String
showsPrec :: Int -> ChainPredicateFailure -> ShowS
$cshowsPrec :: Int -> ChainPredicateFailure -> ShowS
Show, ChainPredicateFailure -> ChainPredicateFailure -> Bool
(ChainPredicateFailure -> ChainPredicateFailure -> Bool)
-> (ChainPredicateFailure -> ChainPredicateFailure -> Bool)
-> Eq ChainPredicateFailure
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
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
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
$cp1Ord :: Eq ChainPredicateFailure
Ord)

instance NoThunks ChainPredicateFailure

chainChecks ::
  MonadError ChainPredicateFailure m =>
  Natural ->
  ChainChecksPParams ->
  BHeaderView crypto ->
  m ()
chainChecks :: Natural -> ChainChecksPParams -> BHeaderView crypto -> m ()
chainChecks Natural
maxpv ChainChecksPParams
ccd BHeaderView crypto
bhv = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Natural
m Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= Natural
maxpv) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ ChainPredicateFailure -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Natural -> Natural -> ChainPredicateFailure
ObsoleteNodeCHAIN Natural
m Natural
maxpv)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (BHeaderView crypto -> Int
forall crypto. BHeaderView crypto -> Int
bhviewHSize BHeaderView crypto
bhv) Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= ChainChecksPParams -> Natural
ccMaxBHSize ChainChecksPParams
ccd) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    ChainPredicateFailure -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChainPredicateFailure -> m ()) -> ChainPredicateFailure -> m ()
forall a b. (a -> b) -> a -> b
$
      Natural -> Natural -> ChainPredicateFailure
HeaderSizeTooLargeCHAIN (Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ BHeaderView crypto -> Int
forall crypto. BHeaderView crypto -> Int
bhviewHSize BHeaderView crypto
bhv) (ChainChecksPParams -> Natural
ccMaxBHSize ChainChecksPParams
ccd)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BHeaderView crypto -> Natural
forall crypto. BHeaderView crypto -> Natural
bhviewBSize BHeaderView crypto
bhv Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= ChainChecksPParams -> Natural
ccMaxBBSize ChainChecksPParams
ccd) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
    ChainPredicateFailure -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ChainPredicateFailure -> m ()) -> ChainPredicateFailure -> m ()
forall a b. (a -> b) -> a -> b
$
      Natural -> Natural -> ChainPredicateFailure
BlockSizeTooLargeCHAIN (BHeaderView crypto -> Natural
forall crypto. BHeaderView crypto -> Natural
bhviewBSize BHeaderView crypto
bhv) (ChainChecksPParams -> Natural
ccMaxBBSize ChainChecksPParams
ccd)
  where
    (ProtVer Natural
m Natural
_) = ChainChecksPParams -> ProtVer
ccProtocolVersion ChainChecksPParams
ccd