{-# 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
    (Property -> TSProperty)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> TSProperty
forall b c a. (b -> c) -> (a -> b) -> a -> c
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
PropertyT IO () -> Property
property
    (PropertyT IO () -> TSProperty) -> PropertyT IO () -> TSProperty
forall a b. (a -> b) -> a -> b
$ do
      -- Generate abstract `PParamsAddrsAndUTxO`
      ppau@(PParamsAddrsAndUTxO abstractPparams _ abstractUtxo) <-
        Gen PParamsAddrsAndUTxO -> PropertyT IO PParamsAddrsAndUTxO
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen PParamsAddrsAndUTxO -> PropertyT IO PParamsAddrsAndUTxO)
-> Gen PParamsAddrsAndUTxO -> PropertyT IO PParamsAddrsAndUTxO
forall a b. (a -> b) -> a -> b
$ Range Int -> Gen PParamsAddrsAndUTxO
genPParamsAddrsAndUTxO (Int -> Int -> Range Int
forall a. a -> a -> Range a
Range.constant Int
1 Int
5)

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

      -- Generate abstract transaction and elaborate.
      abstractTxWits <- forAll $ genValidTxWits ppau txIdMap
      let 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
Dummy.aProtocolMagic
          env = AProtocolMagic ByteString
-> ProtocolParameters -> UTxOConfiguration -> Environment
Environment AProtocolMagic ByteString
pm ProtocolParameters
pparams UTxOConfiguration
UTxO.defaultUTxOConfiguration
      vMode <- forAll $ ValidationMode BlockValidation <$> genValidationMode
      updateRes <-
        (`runReaderT` vMode)
          . runExceptT
          $ UTxO.updateUTxO env utxo [tx]
      void $ evalEither 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
    (Property -> TSProperty)
-> (PropertyT IO () -> Property) -> PropertyT IO () -> TSProperty
forall b c a. (b -> c) -> (a -> b) -> a -> c
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
PropertyT IO () -> Property
property
    (PropertyT IO () -> TSProperty) -> PropertyT IO () -> TSProperty
forall a b. (a -> b) -> a -> b
$ do
      -- Generate abstract `PParamsAddrsAndUTxO`
      ppau@(PParamsAddrsAndUTxO abstractPparams _ abstractUtxo) <-
        Gen PParamsAddrsAndUTxO -> PropertyT IO PParamsAddrsAndUTxO
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen PParamsAddrsAndUTxO -> PropertyT IO PParamsAddrsAndUTxO)
-> Gen PParamsAddrsAndUTxO -> PropertyT IO PParamsAddrsAndUTxO
forall a b. (a -> b) -> a -> b
$ Range Int -> Gen PParamsAddrsAndUTxO
genPParamsAddrsAndUTxO (Int -> Int -> Range Int
forall a. a -> a -> Range a
Range.constant Int
1 Int
5)

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

      -- Generate abstract transaction and elaborate.
      abstractTxWits <- forAll $ genValidTxWits ppau txIdMap
      let 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
Dummy.aProtocolMagic
      invalidWitness <-
        forAll
          $ Annotated
          <$> ( V.fromList
                  <$> Gen.list
                    (Range.linear 1 10)
                    (genVKWitness (getProtocolMagicId pm))
              )
          <*> genBytes 32
      let txInvalidWit = ATxAux ByteString
tx {aTaWitness = invalidWitness}

      -- Validate the generated concrete transaction
      let env = AProtocolMagic ByteString
-> ProtocolParameters -> UTxOConfiguration -> Environment
Environment AProtocolMagic ByteString
pm ProtocolParameters
pparams UTxOConfiguration
UTxO.defaultUTxOConfiguration
      vMode <- forAll $ ValidationMode BlockValidation <$> genValidationMode
      updateRes <-
        (`runReaderT` vMode)
          . runExceptT
          $ UTxO.updateUTxO env utxo [txInvalidWit]
      case updateRes of
        Left UTxOValidationError
err ->
          if UTxOValidationError -> Bool
isInvalidWitnessError UTxOValidationError
err
            Bool -> Bool -> Bool
&& (ValidationMode -> TxValidationMode
txValidationMode ValidationMode
vMode)
            TxValidationMode -> TxValidationMode -> Bool
forall a. Eq a => a -> a -> Bool
== TxValidationMode
TxValidation
            then PropertyT IO ()
forall (m :: * -> *). MonadTest m => m ()
success
            else PropertyT IO ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure
        Right UTxO
_ ->
          if (ValidationMode -> TxValidationMode
txValidationMode ValidationMode
vMode) TxValidationMode -> TxValidationMode -> Bool
forall a. Eq a => a -> a -> Bool
== TxValidationMode
TxValidation
            then PropertyT IO ()
forall (m :: * -> *) a. (MonadTest m, HasCallStack) => m a
failure
            else PropertyT IO ()
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 = Range Int -> GenT Identity Addr -> Gen [Addr]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list Range Int
r GenT Identity Addr
Abstract.addrGen

genInitialAbstractUTxO :: [Abstract.Addr] -> Gen Abstract.UTxO
genInitialAbstractUTxO :: [Addr] -> Gen UTxO
genInitialAbstractUTxO [Addr]
addrs =
  [TxOut] -> UTxO
Abstract.fromTxOuts ([TxOut] -> UTxO) -> GenT Identity [TxOut] -> Gen UTxO
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Addr] -> GenT Identity [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
  abstractPparams <- Gen PParams
Abstract.pparamsGen
  abstractAddrs <- genAbstractAddrs addrRange
  abstractUtxo <- genInitialAbstractUTxO abstractAddrs
  pure $ PParamsAddrsAndUTxO abstractPparams abstractAddrs 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 :: PParams
ppauPParams :: PParamsAddrsAndUTxO -> PParams
ppauPParams
      , [Addr]
ppauAddrs :: [Addr]
ppauAddrs :: PParamsAddrsAndUTxO -> [Addr]
ppauAddrs
      , UTxO
ppauUTxO :: UTxO
ppauUTxO :: PParamsAddrsAndUTxO -> UTxO
ppauUTxO
      } = PParamsAddrsAndUTxO
ppau

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

genValidationMode :: Gen TxValidationMode
genValidationMode :: GenT Identity TxValidationMode
genValidationMode =
  [TxValidationMode] -> GenT Identity TxValidationMode
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, 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
(Int -> PParamsAddrsAndUTxO -> ShowS)
-> (PParamsAddrsAndUTxO -> String)
-> ([PParamsAddrsAndUTxO] -> ShowS)
-> Show PParamsAddrsAndUTxO
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PParamsAddrsAndUTxO -> ShowS
showsPrec :: Int -> PParamsAddrsAndUTxO -> ShowS
$cshow :: PParamsAddrsAndUTxO -> String
show :: PParamsAddrsAndUTxO -> String
$cshowList :: [PParamsAddrsAndUTxO] -> ShowS
showList :: [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 ->
          (LovelaceError -> Lovelace)
-> (Lovelace -> Lovelace)
-> Either LovelaceError Lovelace
-> Lovelace
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
            (Text -> Lovelace
forall a. HasCallStack => Text -> a
panic (Text -> Lovelace)
-> (LovelaceError -> Text) -> LovelaceError -> Lovelace
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. LovelaceError -> Text
forall a b. (Show a, ConvertText String b) => a -> b
show)
            (\Lovelace
x -> Lovelace
x)
            ( TxSizeLinear -> Natural -> Either LovelaceError Lovelace
calculateTxSizeLinear
                TxSizeLinear
txSizeLinear
                (Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
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 Integer -> Integer -> Integer
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 TxId -> Map TxId TxId -> Maybe TxId
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup TxId
abstractTxId Map TxId TxId
txIdMap of
    Maybe TxId
Nothing -> Text -> TxId
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