{-# LANGUAGE FlexibleContexts #-}

module Cardano.Chain.ValidationMode (
  ValidationMode (..),
  fromBlockValidationMode,
  orThrowErrorInBlockValidationMode,
  askBlockValidationMode,
  askTxValidationMode,
  whenBlockValidation,
  whenTxValidation,
  unlessNoTxValidation,
  wrapErrorWithValidationMode,
)
where

import Cardano.Chain.Block.ValidationMode (
  BlockValidationMode (..),
  toTxValidationMode,
 )
import Cardano.Chain.UTxO.ValidationMode (TxValidationMode (..))
import Cardano.Prelude

--------------------------------------------------------------------------------
-- ValidationMode
--------------------------------------------------------------------------------

data ValidationMode = ValidationMode
  { ValidationMode -> BlockValidationMode
blockValidationMode :: !BlockValidationMode
  , ValidationMode -> TxValidationMode
txValidationMode :: !TxValidationMode
  }
  deriving (Int -> ValidationMode -> ShowS
[ValidationMode] -> ShowS
ValidationMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidationMode] -> ShowS
$cshowList :: [ValidationMode] -> ShowS
show :: ValidationMode -> String
$cshow :: ValidationMode -> String
showsPrec :: Int -> ValidationMode -> ShowS
$cshowsPrec :: Int -> ValidationMode -> ShowS
Show)

-- | Helper function which accepts a 'BlockValidationMode', constructs a
-- sensible 'TxValidationMode' based on that, and constructs a
-- 'ValidationMode'
fromBlockValidationMode :: BlockValidationMode -> ValidationMode
fromBlockValidationMode :: BlockValidationMode -> ValidationMode
fromBlockValidationMode BlockValidationMode
bvm =
  ValidationMode
    { blockValidationMode :: BlockValidationMode
blockValidationMode = BlockValidationMode
bvm
    , txValidationMode :: TxValidationMode
txValidationMode = BlockValidationMode -> TxValidationMode
toTxValidationMode BlockValidationMode
bvm
    }

orThrowErrorInBlockValidationMode ::
  (MonadError e m, MonadReader ValidationMode m) =>
  Bool ->
  e ->
  m ()
orThrowErrorInBlockValidationMode :: forall e (m :: * -> *).
(MonadError e m, MonadReader ValidationMode m) =>
Bool -> e -> m ()
orThrowErrorInBlockValidationMode Bool
condition e
err = do
  BlockValidationMode
bvm <- forall (m :: * -> *).
MonadReader ValidationMode m =>
m BlockValidationMode
askBlockValidationMode
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (BlockValidationMode
bvm forall a. Eq a => a -> a -> Bool
== BlockValidationMode
NoBlockValidation Bool -> Bool -> Bool
|| Bool
condition) (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
err)

infix 1 `orThrowErrorInBlockValidationMode`

--------------------------------------------------------------------------------
-- ValidationMode Helpers
--------------------------------------------------------------------------------

askBlockValidationMode ::
  MonadReader ValidationMode m =>
  m BlockValidationMode
askBlockValidationMode :: forall (m :: * -> *).
MonadReader ValidationMode m =>
m BlockValidationMode
askBlockValidationMode = ValidationMode -> BlockValidationMode
blockValidationMode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask

askTxValidationMode ::
  MonadReader ValidationMode m =>
  m TxValidationMode
askTxValidationMode :: forall (m :: * -> *).
MonadReader ValidationMode m =>
m TxValidationMode
askTxValidationMode = ValidationMode -> TxValidationMode
txValidationMode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *). MonadReader r m => m r
ask

-- | Perform an action only when in the 'BlockValidation' mode. Otherwise, do
-- nothing.
whenBlockValidation ::
  (MonadError err m, MonadReader ValidationMode m) =>
  m () ->
  m ()
whenBlockValidation :: forall err (m :: * -> *).
(MonadError err m, MonadReader ValidationMode m) =>
m () -> m ()
whenBlockValidation m ()
action = do
  BlockValidationMode
bvmode <- forall (m :: * -> *).
MonadReader ValidationMode m =>
m BlockValidationMode
askBlockValidationMode
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockValidationMode
bvmode forall a. Eq a => a -> a -> Bool
== BlockValidationMode
BlockValidation) m ()
action

-- | Perform an action only when in the 'TxValidation' mode. Otherwise, do
-- nothing.
whenTxValidation ::
  (MonadError err m, MonadReader ValidationMode m) =>
  m () ->
  m ()
whenTxValidation :: forall err (m :: * -> *).
(MonadError err m, MonadReader ValidationMode m) =>
m () -> m ()
whenTxValidation m ()
action = do
  TxValidationMode
tvmode <- forall (m :: * -> *).
MonadReader ValidationMode m =>
m TxValidationMode
askTxValidationMode
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TxValidationMode
tvmode forall a. Eq a => a -> a -> Bool
== TxValidationMode
TxValidation) m ()
action

-- | Perform an action unless in the 'NoTxValidation' mode.
unlessNoTxValidation ::
  (MonadError err m, MonadReader ValidationMode m) =>
  m () ->
  m ()
unlessNoTxValidation :: forall err (m :: * -> *).
(MonadError err m, MonadReader ValidationMode m) =>
m () -> m ()
unlessNoTxValidation m ()
action = do
  TxValidationMode
tvmode <- forall (m :: * -> *).
MonadReader ValidationMode m =>
m TxValidationMode
askTxValidationMode
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TxValidationMode
tvmode forall a. Eq a => a -> a -> Bool
== TxValidationMode
NoTxValidation) m ()
action

wrapErrorWithValidationMode ::
  (MonadError e' m, MonadReader ValidationMode m) =>
  ReaderT ValidationMode (Either e) a ->
  (e -> e') ->
  m a
wrapErrorWithValidationMode :: forall e' (m :: * -> *) e a.
(MonadError e' m, MonadReader ValidationMode m) =>
ReaderT ValidationMode (Either e) a -> (e -> e') -> m a
wrapErrorWithValidationMode ReaderT ValidationMode (Either e) a
rt e -> e'
wrapper = do
  ValidationMode
vMode <- forall r (m :: * -> *). MonadReader r m => m r
ask
  case forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT ValidationMode (Either e) a
rt ValidationMode
vMode of
    Left e
err -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ e -> e'
wrapper e
err
    Right a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x

infix 1 `wrapErrorWithValidationMode`