{-# 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
ppau@(PParamsAddrsAndUTxO PParams
abstractPparams [Addr]
_ UTxO
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 :: 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 <- Gen Tx -> PropertyT IO Tx
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen Tx -> PropertyT IO Tx) -> Gen Tx -> PropertyT IO Tx
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 <- Gen ValidationMode -> PropertyT IO ValidationMode
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen ValidationMode -> PropertyT IO ValidationMode)
-> Gen ValidationMode -> PropertyT IO ValidationMode
forall a b. (a -> b) -> a -> b
$ BlockValidationMode -> TxValidationMode -> ValidationMode
ValidationMode BlockValidationMode
BlockValidation (TxValidationMode -> ValidationMode)
-> GenT Identity TxValidationMode -> Gen ValidationMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity TxValidationMode
genValidationMode
      Either UTxOValidationError UTxO
updateRes <-
        (ReaderT
  ValidationMode (PropertyT IO) (Either UTxOValidationError UTxO)
-> ValidationMode -> PropertyT IO (Either UTxOValidationError UTxO)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ValidationMode
vMode)
          (ReaderT
   ValidationMode (PropertyT IO) (Either UTxOValidationError UTxO)
 -> PropertyT IO (Either UTxOValidationError UTxO))
-> (ExceptT
      UTxOValidationError (ReaderT ValidationMode (PropertyT IO)) UTxO
    -> ReaderT
         ValidationMode (PropertyT IO) (Either UTxOValidationError UTxO))
-> ExceptT
     UTxOValidationError (ReaderT ValidationMode (PropertyT IO)) UTxO
-> PropertyT IO (Either UTxOValidationError UTxO)
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
. ExceptT
  UTxOValidationError (ReaderT ValidationMode (PropertyT IO)) UTxO
-> ReaderT
     ValidationMode (PropertyT IO) (Either UTxOValidationError UTxO)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
          (ExceptT
   UTxOValidationError (ReaderT ValidationMode (PropertyT IO)) UTxO
 -> PropertyT IO (Either UTxOValidationError UTxO))
-> ExceptT
     UTxOValidationError (ReaderT ValidationMode (PropertyT IO)) UTxO
-> PropertyT IO (Either UTxOValidationError UTxO)
forall a b. (a -> b) -> a -> b
$ Environment
-> UTxO
-> [ATxAux ByteString]
-> ExceptT
     UTxOValidationError (ReaderT ValidationMode (PropertyT IO)) UTxO
forall (m :: * -> *).
(MonadError UTxOValidationError m, MonadReader ValidationMode m) =>
Environment -> UTxO -> [ATxAux ByteString] -> m UTxO
UTxO.updateUTxO Environment
env UTxO
utxo [ATxAux ByteString
tx]
      PropertyT IO UTxO -> PropertyT IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (PropertyT IO UTxO -> PropertyT IO ())
-> PropertyT IO UTxO -> PropertyT IO ()
forall a b. (a -> b) -> a -> b
$ Either UTxOValidationError UTxO -> PropertyT IO UTxO
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
    (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
ppau@(PParamsAddrsAndUTxO PParams
abstractPparams [Addr]
_ UTxO
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 :: 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 <- Gen Tx -> PropertyT IO Tx
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen Tx -> PropertyT IO Tx) -> Gen Tx -> PropertyT IO Tx
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 <-
        Gen (Annotated (Vector TxInWitness) ByteString)
-> PropertyT IO (Annotated (Vector TxInWitness) ByteString)
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll
          (Gen (Annotated (Vector TxInWitness) ByteString)
 -> PropertyT IO (Annotated (Vector TxInWitness) ByteString))
-> Gen (Annotated (Vector TxInWitness) ByteString)
-> PropertyT IO (Annotated (Vector TxInWitness) ByteString)
forall a b. (a -> b) -> a -> b
$ Vector TxInWitness
-> ByteString -> Annotated (Vector TxInWitness) ByteString
forall b a. b -> a -> Annotated b a
Annotated
          (Vector TxInWitness
 -> ByteString -> Annotated (Vector TxInWitness) ByteString)
-> GenT Identity (Vector TxInWitness)
-> GenT
     Identity (ByteString -> Annotated (Vector TxInWitness) ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( [TxInWitness] -> Vector TxInWitness
forall a. [a] -> Vector a
V.fromList
                  ([TxInWitness] -> Vector TxInWitness)
-> GenT Identity [TxInWitness]
-> GenT Identity (Vector TxInWitness)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Range Int
-> GenT Identity TxInWitness -> GenT Identity [TxInWitness]
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list
                    (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
1 Int
10)
                    (ProtocolMagicId -> GenT Identity TxInWitness
genVKWitness (AProtocolMagic ByteString -> ProtocolMagicId
forall a. AProtocolMagic a -> ProtocolMagicId
getProtocolMagicId AProtocolMagic ByteString
pm))
              )
          GenT
  Identity (ByteString -> Annotated (Vector TxInWitness) ByteString)
-> GenT Identity ByteString
-> Gen (Annotated (Vector TxInWitness) ByteString)
forall a b.
GenT Identity (a -> b) -> GenT Identity a -> GenT Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> GenT Identity ByteString
genBytes Int
32
      let txInvalidWit :: ATxAux ByteString
txInvalidWit = ATxAux ByteString
tx {aTaWitness = 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 <- Gen ValidationMode -> PropertyT IO ValidationMode
forall (m :: * -> *) a.
(Monad m, Show a, HasCallStack) =>
Gen a -> PropertyT m a
forAll (Gen ValidationMode -> PropertyT IO ValidationMode)
-> Gen ValidationMode -> PropertyT IO ValidationMode
forall a b. (a -> b) -> a -> b
$ BlockValidationMode -> TxValidationMode -> ValidationMode
ValidationMode BlockValidationMode
BlockValidation (TxValidationMode -> ValidationMode)
-> GenT Identity TxValidationMode -> Gen ValidationMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenT Identity TxValidationMode
genValidationMode
      Either UTxOValidationError UTxO
updateRes <-
        (ReaderT
  ValidationMode (PropertyT IO) (Either UTxOValidationError UTxO)
-> ValidationMode -> PropertyT IO (Either UTxOValidationError UTxO)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` ValidationMode
vMode)
          (ReaderT
   ValidationMode (PropertyT IO) (Either UTxOValidationError UTxO)
 -> PropertyT IO (Either UTxOValidationError UTxO))
-> (ExceptT
      UTxOValidationError (ReaderT ValidationMode (PropertyT IO)) UTxO
    -> ReaderT
         ValidationMode (PropertyT IO) (Either UTxOValidationError UTxO))
-> ExceptT
     UTxOValidationError (ReaderT ValidationMode (PropertyT IO)) UTxO
-> PropertyT IO (Either UTxOValidationError UTxO)
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
. ExceptT
  UTxOValidationError (ReaderT ValidationMode (PropertyT IO)) UTxO
-> ReaderT
     ValidationMode (PropertyT IO) (Either UTxOValidationError UTxO)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
          (ExceptT
   UTxOValidationError (ReaderT ValidationMode (PropertyT IO)) UTxO
 -> PropertyT IO (Either UTxOValidationError UTxO))
-> ExceptT
     UTxOValidationError (ReaderT ValidationMode (PropertyT IO)) UTxO
-> PropertyT IO (Either UTxOValidationError UTxO)
forall a b. (a -> b) -> a -> b
$ Environment
-> UTxO
-> [ATxAux ByteString]
-> ExceptT
     UTxOValidationError (ReaderT ValidationMode (PropertyT IO)) UTxO
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)
            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
  PParams
abstractPparams <- Gen PParams
Abstract.pparamsGen
  [Addr]
abstractAddrs <- Range Int -> Gen [Addr]
genAbstractAddrs Range Int
addrRange
  UTxO
abstractUtxo <- [Addr] -> Gen UTxO
genInitialAbstractUTxO [Addr]
abstractAddrs
  PParamsAddrsAndUTxO -> Gen PParamsAddrsAndUTxO
forall a. a -> GenT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PParamsAddrsAndUTxO -> Gen PParamsAddrsAndUTxO)
-> PParamsAddrsAndUTxO -> Gen PParamsAddrsAndUTxO
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 :: 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.
(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