{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

module Test.Cardano.Chain.UTxO.ValidationMode (
  tests,
)
where

import qualified Byron.Spec.Ledger.Core as Abstract
import qualified Byron.Spec.Ledger.Core.Generators as Abstract
import qualified Byron.Spec.Ledger.UTxO as Abstract
import qualified Byron.Spec.Ledger.UTxO.Generators as Abstract
import qualified Byron.Spec.Ledger.Update as Abstract
import qualified Byron.Spec.Ledger.Update.Generators as Abstract
import Cardano.Chain.Block (BlockValidationMode (..))
import Cardano.Chain.Common (
  TxFeePolicy (..),
  calculateTxSizeLinear,
  lovelaceToInteger,
 )
import Cardano.Chain.UTxO (
  ATxAux (..),
  Environment (..),
  TxId,
  TxValidationError (..),
  TxValidationMode (..),
  UTxOValidationError (..),
 )
import qualified Cardano.Chain.UTxO as UTxO
import Cardano.Chain.Update (ProtocolParameters (..))
import Cardano.Chain.ValidationMode (ValidationMode (..))
import Cardano.Crypto (getProtocolMagicId)
import Cardano.Ledger.Binary (Annotated (..))
import Cardano.Prelude
import qualified Data.ByteString as BS
import qualified Data.Map.Strict as M
import qualified Data.Vector as V
import Hedgehog
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Test.Cardano.Chain.Elaboration.UTxO (elaborateTxBS)
import Test.Cardano.Chain.Elaboration.Update (elaboratePParams)
import Test.Cardano.Chain.UTxO.Gen (genVKWitness)
import Test.Cardano.Chain.UTxO.Model (elaborateInitialUTxO)
import qualified Test.Cardano.Crypto.Dummy as Dummy
import Test.Cardano.Prelude
import Test.Options (TSGroup, TSProperty, withTestsTS)

--------------------------------------------------------------------------------
-- TxValidationMode Properties
--------------------------------------------------------------------------------

-- | Property: When calling 'updateUTxO' given a valid transaction, 'UTxO'
-- validation should pass in all 'TxValidationMode's.
ts_prop_updateUTxO_Valid :: TSProperty
ts_prop_updateUTxO_Valid :: TSProperty
ts_prop_updateUTxO_Valid =
  TestLimit -> Property -> TSProperty
withTestsTS TestLimit
300
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => PropertyT IO () -> Property
property
    forall a b. (a -> b) -> a -> b
$ do
      -- Generate abstract `PParamsAddrsAndUTxO`
      ppau :: PParamsAddrsAndUTxO
ppau@(PParamsAddrsAndUTxO PParams
abstractPparams [Addr]
_ UTxO
abstractUtxo) <-
        forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ Range Int -> Gen PParamsAddrsAndUTxO
genPParamsAddrsAndUTxO (forall a. a -> a -> Range a
Range.constant Int
1 Int
5)

      -- Elaborate abstract values to concrete.
      let pparams :: ProtocolParameters
pparams = PParams -> ProtocolParameters
elaboratePParams PParams
abstractPparams
          (UTxO
utxo, Map TxId TxId
txIdMap) = UTxO -> (UTxO, Map TxId TxId)
elaborateInitialUTxO UTxO
abstractUtxo

      -- Generate abstract transaction and elaborate.
      Tx
abstractTxWits <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ PParamsAddrsAndUTxO -> Map TxId TxId -> Gen Tx
genValidTxWits PParamsAddrsAndUTxO
ppau Map TxId TxId
txIdMap
      let tx :: ATxAux ByteString
tx =
            (TxId -> TxId) -> Tx -> ATxAux ByteString
elaborateTxBS
              (Map TxId TxId -> TxId -> TxId
elaborateTxId Map TxId TxId
txIdMap)
              Tx
abstractTxWits

      -- Validate the generated concrete transaction
      let pm :: AProtocolMagic ByteString
pm = AProtocolMagic ByteString
Dummy.aProtocolMagic
          env :: Environment
env = AProtocolMagic ByteString
-> ProtocolParameters -> UTxOConfiguration -> Environment
Environment AProtocolMagic ByteString
pm ProtocolParameters
pparams UTxOConfiguration
UTxO.defaultUTxOConfiguration
      ValidationMode
vMode <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ BlockValidationMode -> TxValidationMode -> ValidationMode
ValidationMode BlockValidationMode
BlockValidation forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxValidationMode
genValidationMode
      Either UTxOValidationError UTxO
updateRes <-
        (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ValidationMode
vMode)
          forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
          forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError UTxOValidationError m, MonadReader ValidationMode m) =>
Environment -> UTxO -> [ATxAux ByteString] -> m UTxO
UTxO.updateUTxO Environment
env UTxO
utxo [ATxAux ByteString
tx]
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) x a.
(MonadTest m, Show x, HasCallStack) =>
Either x a -> m a
evalEither Either UTxOValidationError UTxO
updateRes

-- | Property: When calling 'updateUTxO' given a valid transaction with an
-- invalid witness, 'UTxO' validation should pass in both the
-- 'TxValidationNoCrypto' and 'NoTxValidation' modes. This is because neither
-- of these modes verify the cryptographic integrity of a transaction.
ts_prop_updateUTxO_InvalidWit :: TSProperty
ts_prop_updateUTxO_InvalidWit :: TSProperty
ts_prop_updateUTxO_InvalidWit =
  TestLimit -> Property -> TSProperty
withTestsTS TestLimit
300
    forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. HasCallStack => PropertyT IO () -> Property
property
    forall a b. (a -> b) -> a -> b
$ do
      -- Generate abstract `PParamsAddrsAndUTxO`
      ppau :: PParamsAddrsAndUTxO
ppau@(PParamsAddrsAndUTxO PParams
abstractPparams [Addr]
_ UTxO
abstractUtxo) <-
        forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ Range Int -> Gen PParamsAddrsAndUTxO
genPParamsAddrsAndUTxO (forall a. a -> a -> Range a
Range.constant Int
1 Int
5)

      -- Elaborate abstract values to concrete.
      let pparams :: ProtocolParameters
pparams = PParams -> ProtocolParameters
elaboratePParams PParams
abstractPparams
          (UTxO
utxo, Map TxId TxId
txIdMap) = UTxO -> (UTxO, Map TxId TxId)
elaborateInitialUTxO UTxO
abstractUtxo

      -- Generate abstract transaction and elaborate.
      Tx
abstractTxWits <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ PParamsAddrsAndUTxO -> Map TxId TxId -> Gen Tx
genValidTxWits PParamsAddrsAndUTxO
ppau Map TxId TxId
txIdMap
      let tx :: ATxAux ByteString
tx =
            (TxId -> TxId) -> Tx -> ATxAux ByteString
elaborateTxBS
              (Map TxId TxId -> TxId -> TxId
elaborateTxId Map TxId TxId
txIdMap)
              Tx
abstractTxWits

      -- Generate an invalid 'TxWitness' and utilize it in the valid
      -- transaction generated above.
      let pm :: AProtocolMagic ByteString
pm = AProtocolMagic ByteString
Dummy.aProtocolMagic
      Annotated (Vector TxInWitness) ByteString
invalidWitness <-
        forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll
          forall a b. (a -> b) -> a -> b
$ forall b a. b -> a -> Annotated b a
Annotated
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( forall a. [a] -> Vector a
V.fromList
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list
                    (forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
10)
                    (ProtocolMagicId -> Gen TxInWitness
genVKWitness (forall a. AProtocolMagic a -> ProtocolMagicId
getProtocolMagicId AProtocolMagic ByteString
pm))
              )
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Gen ByteString
genBytes Int
32
      let txInvalidWit :: ATxAux ByteString
txInvalidWit = ATxAux ByteString
tx {aTaWitness :: Annotated (Vector TxInWitness) ByteString
aTaWitness = Annotated (Vector TxInWitness) ByteString
invalidWitness}

      -- Validate the generated concrete transaction
      let env :: Environment
env = AProtocolMagic ByteString
-> ProtocolParameters -> UTxOConfiguration -> Environment
Environment AProtocolMagic ByteString
pm ProtocolParameters
pparams UTxOConfiguration
UTxO.defaultUTxOConfiguration
      ValidationMode
vMode <- forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll forall a b. (a -> b) -> a -> b
$ BlockValidationMode -> TxValidationMode -> ValidationMode
ValidationMode BlockValidationMode
BlockValidation forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen TxValidationMode
genValidationMode
      Either UTxOValidationError UTxO
updateRes <-
        (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ValidationMode
vMode)
          forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
          forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError UTxOValidationError m, MonadReader ValidationMode m) =>
Environment -> UTxO -> [ATxAux ByteString] -> m UTxO
UTxO.updateUTxO Environment
env UTxO
utxo [ATxAux ByteString
txInvalidWit]
      case Either UTxOValidationError UTxO
updateRes of
        Left UTxOValidationError
err ->
          if UTxOValidationError -> Bool
isInvalidWitnessError UTxOValidationError
err
            Bool -> Bool -> Bool
&& (ValidationMode -> TxValidationMode
txValidationMode ValidationMode
vMode)
            forall a. Eq a => a -> a -> Bool
== TxValidationMode
TxValidation
            then forall (m :: * -> *). MonadTest m => m ()
success
            else forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure
        Right UTxO
_ ->
          if (ValidationMode -> TxValidationMode
txValidationMode ValidationMode
vMode) forall a. Eq a => a -> a -> Bool
== TxValidationMode
TxValidation
            then forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure
            else forall (m :: * -> *). MonadTest m => m ()
success
  where
    isInvalidWitnessError :: UTxOValidationError -> Bool
    isInvalidWitnessError :: UTxOValidationError -> Bool
isInvalidWitnessError (UTxOValidationTxValidationError TxValidationError
err) = case TxValidationError
err of
      TxValidationWitnessWrongSignature {} -> Bool
True
      TxValidationWitnessWrongKey {} -> Bool
True
      TxValidationError
_ -> Bool
False
    isInvalidWitnessError UTxOValidationError
_ = Bool
False

--------------------------------------------------------------------------------
-- Generators
--------------------------------------------------------------------------------

genAbstractAddrs :: Range Int -> Gen [Abstract.Addr]
genAbstractAddrs :: Range Int -> Gen [Addr]
genAbstractAddrs Range Int
r = forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list Range Int
r Gen Addr
Abstract.addrGen

genInitialAbstractUTxO :: [Abstract.Addr] -> Gen Abstract.UTxO
genInitialAbstractUTxO :: [Addr] -> Gen UTxO
genInitialAbstractUTxO [Addr]
addrs =
  [TxOut] -> UTxO
Abstract.fromTxOuts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Addr] -> Gen [TxOut]
Abstract.genInitialTxOuts [Addr]
addrs

genPParamsAddrsAndUTxO ::
  -- | Range for generation of 'Abstract.Addr's.
  Range Int ->
  Gen PParamsAddrsAndUTxO
genPParamsAddrsAndUTxO :: Range Int -> Gen PParamsAddrsAndUTxO
genPParamsAddrsAndUTxO Range Int
addrRange = do
  PParams
abstractPparams <- Gen PParams
Abstract.pparamsGen
  [Addr]
abstractAddrs <- Range Int -> Gen [Addr]
genAbstractAddrs Range Int
addrRange
  UTxO
abstractUtxo <- [Addr] -> Gen UTxO
genInitialAbstractUTxO [Addr]
abstractAddrs
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PParams -> [Addr] -> UTxO -> PParamsAddrsAndUTxO
PParamsAddrsAndUTxO PParams
abstractPparams [Addr]
abstractAddrs UTxO
abstractUtxo

genValidTxWits ::
  PParamsAddrsAndUTxO ->
  Map Abstract.TxId TxId ->
  Gen Abstract.Tx
genValidTxWits :: PParamsAddrsAndUTxO -> Map TxId TxId -> Gen Tx
genValidTxWits PParamsAddrsAndUTxO
ppau Map TxId TxId
txIdMap = do
  [Addr] -> (Tx -> Lovelace) -> UTxO -> Gen Tx
Abstract.genTxFromUTxO
    [Addr]
ppauAddrs
    (Map TxId TxId -> TxFeePolicy -> Tx -> Lovelace
abstractTxFee Map TxId TxId
txIdMap (ProtocolParameters -> TxFeePolicy
ppTxFeePolicy ProtocolParameters
pparams))
    UTxO
ppauUTxO
  where
    PParamsAddrsAndUTxO
      { PParams
ppauPParams :: PParamsAddrsAndUTxO -> PParams
ppauPParams :: PParams
ppauPParams
      , [Addr]
ppauAddrs :: PParamsAddrsAndUTxO -> [Addr]
ppauAddrs :: [Addr]
ppauAddrs
      , UTxO
ppauUTxO :: PParamsAddrsAndUTxO -> UTxO
ppauUTxO :: UTxO
ppauUTxO
      } = PParamsAddrsAndUTxO
ppau

    pparams :: ProtocolParameters
pparams = PParams -> ProtocolParameters
elaboratePParams PParams
ppauPParams

genValidationMode :: Gen TxValidationMode
genValidationMode :: Gen TxValidationMode
genValidationMode =
  forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadGen m) =>
f a -> m a
Gen.element
    [ TxValidationMode
TxValidation
    , TxValidationMode
TxValidationNoCrypto
    , TxValidationMode
NoTxValidation
    ]

--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------

data PParamsAddrsAndUTxO = PParamsAddrsAndUTxO
  { PParamsAddrsAndUTxO -> PParams
ppauPParams :: !Abstract.PParams
  , PParamsAddrsAndUTxO -> [Addr]
ppauAddrs :: ![Abstract.Addr]
  , PParamsAddrsAndUTxO -> UTxO
ppauUTxO :: !Abstract.UTxO
  }
  deriving (Int -> PParamsAddrsAndUTxO -> ShowS
[PParamsAddrsAndUTxO] -> ShowS
PParamsAddrsAndUTxO -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PParamsAddrsAndUTxO] -> ShowS
$cshowList :: [PParamsAddrsAndUTxO] -> ShowS
show :: PParamsAddrsAndUTxO -> String
$cshow :: PParamsAddrsAndUTxO -> String
showsPrec :: Int -> PParamsAddrsAndUTxO -> ShowS
$cshowsPrec :: Int -> PParamsAddrsAndUTxO -> ShowS
Show)

-- | Elaborate an 'Abstract.Tx', calculate the 'Concrete.Lovelace' fee, then
-- convert back to an 'Abstract.Lovelace'.
-- n.b. Calculating the fee with 'Abstract.pcMinFee', for example, proved to
-- be ineffective as it utilizes the 'Abstract.Size' of the 'Abstract.Tx' in
-- its calculation when we really need to take into account the actual
-- concrete size in bytes.
abstractTxFee ::
  Map Abstract.TxId UTxO.TxId ->
  TxFeePolicy ->
  Abstract.Tx ->
  Abstract.Lovelace
abstractTxFee :: Map TxId TxId -> TxFeePolicy -> Tx -> Lovelace
abstractTxFee Map TxId TxId
txIdMap TxFeePolicy
tfp Tx
aTx = do
  let ATxAux (Annotated Tx
_ ByteString
txBytes) Annotated (Vector TxInWitness) ByteString
_ ByteString
_ =
        (TxId -> TxId) -> Tx -> ATxAux ByteString
elaborateTxBS
          (Map TxId TxId -> TxId -> TxId
elaborateTxId Map TxId TxId
txIdMap)
          Tx
aTx
      cLovelace :: Lovelace
cLovelace = case TxFeePolicy
tfp of
        TxFeePolicyTxSizeLinear TxSizeLinear
txSizeLinear ->
          forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
            (forall a. HasCallStack => Text -> a
panic forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall a b. (Show a, ConvertText String b) => a -> b
show)
            (\Lovelace
x -> Lovelace
x)
            ( TxSizeLinear -> Natural -> Either LovelaceError Lovelace
calculateTxSizeLinear
                TxSizeLinear
txSizeLinear
                (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
txBytes)
            )
  -- Add an extra lovelace to the fee to compensate for rounding errors
  Integer -> Lovelace
Abstract.Lovelace (Integer
1 forall a. Num a => a -> a -> a
+ Lovelace -> Integer
lovelaceToInteger Lovelace
cLovelace)

elaborateTxId :: Map Abstract.TxId UTxO.TxId -> Abstract.TxId -> TxId
elaborateTxId :: Map TxId TxId -> TxId -> TxId
elaborateTxId Map TxId TxId
txIdMap TxId
abstractTxId =
  case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TxId
abstractTxId Map TxId TxId
txIdMap of
    Maybe TxId
Nothing -> forall a. HasCallStack => Text -> a
panic Text
"elaborateTxId: Missing abstract TxId during elaboration"
    Just TxId
x -> TxId
x

--------------------------------------------------------------------------------
-- Main Test Export
--------------------------------------------------------------------------------

tests :: TSGroup
tests :: TSGroup
tests = $$discoverPropArg