{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Chain.UTxO.Validation (
  validateTx,
  validateTxAux,
  updateUTxO,
  updateUTxOTxWitness,
  updateUTxOTx,
  TxValidationError (..),
  Environment (..),
  UTxOValidationError (..),
)
where

import Cardano.Chain.Common (
  Address (..),
  Lovelace,
  LovelaceError,
  NetworkMagic,
  TxFeePolicy (..),
  addrNetworkMagic,
  calculateTxSizeLinear,
  checkRedeemAddress,
  checkVerKeyAddress,
  makeNetworkMagic,
  mkKnownLovelace,
  subLovelace,
  unknownAttributesLength,
 )
import Cardano.Chain.UTxO.Compact (CompactTxOut (..), toCompactTxIn)
import Cardano.Chain.UTxO.Tx (Tx (..), TxIn, TxOut (..))
import Cardano.Chain.UTxO.TxAux (ATxAux (..), aTaTx, taWitness)
import Cardano.Chain.UTxO.TxWitness (
  TxInWitness (..),
  TxSigData (..),
  recoverSigData,
 )
import Cardano.Chain.UTxO.UTxO (
  UTxO,
  UTxOError,
  balance,
  isRedeemUTxO,
  txOutputUTxO,
  (</|),
  (<|),
 )
import qualified Cardano.Chain.UTxO.UTxO as UTxO
import Cardano.Chain.UTxO.UTxOConfiguration
import Cardano.Chain.Update (ProtocolParameters (..))
import Cardano.Chain.ValidationMode (
  ValidationMode,
  unlessNoTxValidation,
  whenTxValidation,
  wrapErrorWithValidationMode,
 )
import Cardano.Crypto (
  AProtocolMagic (..),
  ProtocolMagicId,
  SignTag (..),
  verifyRedeemSigDecoded,
  verifySignatureDecoded,
 )
import Cardano.Ledger.Binary (
  Annotated (..),
  DecCBOR (..),
  Decoder,
  DecoderError (DecoderErrorUnknownTag),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  cborError,
  decodeListLen,
  decodeWord8,
  encodeListLen,
  enforceSize,
  fromByronCBOR,
  matchSize,
  toByronCBOR,
 )
import Cardano.Prelude hiding (cborError)
import qualified Data.ByteString as BS
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as S
import qualified Data.Vector as V

-- | A representation of all the ways a transaction might be invalid
data TxValidationError
  = TxValidationLovelaceError Text LovelaceError
  | TxValidationFeeTooSmall Tx Lovelace Lovelace
  | TxValidationWitnessWrongSignature TxInWitness ProtocolMagicId TxSigData
  | TxValidationWitnessWrongKey TxInWitness Address
  | TxValidationMissingInput TxIn
  | -- | Fields are <expected> <actual>
    TxValidationNetworkMagicMismatch NetworkMagic NetworkMagic
  | TxValidationTxTooLarge Natural Natural
  | TxValidationUnknownAddressAttributes
  | TxValidationUnknownAttributes
  deriving (TxValidationError -> TxValidationError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TxValidationError -> TxValidationError -> Bool
$c/= :: TxValidationError -> TxValidationError -> Bool
== :: TxValidationError -> TxValidationError -> Bool
$c== :: TxValidationError -> TxValidationError -> Bool
Eq, Int -> TxValidationError -> ShowS
[TxValidationError] -> ShowS
TxValidationError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TxValidationError] -> ShowS
$cshowList :: [TxValidationError] -> ShowS
show :: TxValidationError -> String
$cshow :: TxValidationError -> String
showsPrec :: Int -> TxValidationError -> ShowS
$cshowsPrec :: Int -> TxValidationError -> ShowS
Show)

instance ToCBOR TxValidationError where
  toCBOR :: TxValidationError -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance FromCBOR TxValidationError where
  fromCBOR :: forall s. Decoder s TxValidationError
fromCBOR = forall a s. DecCBOR a => Decoder s a
fromByronCBOR

instance EncCBOR TxValidationError where
  encCBOR :: TxValidationError -> Encoding
encCBOR = \case
    TxValidationLovelaceError Text
text LovelaceError
loveLaceError ->
      Word -> Encoding
encodeListLen Word
3
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR @Word8 Word8
0
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Text
text
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR LovelaceError
loveLaceError
    TxValidationFeeTooSmall Tx
tx Lovelace
lovelace1 Lovelace
lovelace2 ->
      Word -> Encoding
encodeListLen Word
4
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR @Word8 Word8
1
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Tx
tx
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Lovelace
lovelace1
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Lovelace
lovelace2
    TxValidationWitnessWrongSignature TxInWitness
txInWitness ProtocolMagicId
pmi TxSigData
sigData ->
      Word -> Encoding
encodeListLen Word
4
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR @Word8 Word8
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR TxInWitness
txInWitness
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR ProtocolMagicId
pmi
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR TxSigData
sigData
    TxValidationWitnessWrongKey TxInWitness
txInWitness Address
addr ->
      Word -> Encoding
encodeListLen Word
3
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR @Word8 Word8
3
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR TxInWitness
txInWitness
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Address
addr
    TxValidationMissingInput TxIn
txIn ->
      Word -> Encoding
encodeListLen Word
2
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR @Word8 Word8
4
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR TxIn
txIn
    TxValidationNetworkMagicMismatch NetworkMagic
networkMagic1 NetworkMagic
networkMagic2 ->
      Word -> Encoding
encodeListLen Word
3
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR @Word8 Word8
5
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR NetworkMagic
networkMagic1
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR NetworkMagic
networkMagic2
    TxValidationTxTooLarge Natural
nat1 Natural
nat2 ->
      Word -> Encoding
encodeListLen Word
3
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR @Word8 Word8
6
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Natural
nat1
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR Natural
nat2
    TxValidationError
TxValidationUnknownAddressAttributes ->
      Word -> Encoding
encodeListLen Word
1
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR @Word8 Word8
7
    TxValidationError
TxValidationUnknownAttributes ->
      Word -> Encoding
encodeListLen Word
1
        forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR @Word8 Word8
8

instance DecCBOR TxValidationError where
  decCBOR :: forall s. Decoder s TxValidationError
decCBOR = do
    Int
len <- forall s. Decoder s Int
decodeListLen
    let checkSize :: forall s. Int -> Decoder s ()
        checkSize :: forall s. Int -> Decoder s ()
checkSize Int
size = forall s. Text -> Int -> Int -> Decoder s ()
matchSize Text
"TxValidationError" Int
size Int
len
    Word8
tag <- forall s. Decoder s Word8
decodeWord8
    case Word8
tag of
      Word8
0 -> forall s. Int -> Decoder s ()
checkSize Int
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> LovelaceError -> TxValidationError
TxValidationLovelaceError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
1 -> forall s. Int -> Decoder s ()
checkSize Int
4 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Tx -> Lovelace -> Lovelace -> TxValidationError
TxValidationFeeTooSmall forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
2 -> forall s. Int -> Decoder s ()
checkSize Int
4 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TxInWitness -> ProtocolMagicId -> TxSigData -> TxValidationError
TxValidationWitnessWrongSignature forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
3 -> forall s. Int -> Decoder s ()
checkSize Int
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TxInWitness -> Address -> TxValidationError
TxValidationWitnessWrongKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
4 -> forall s. Int -> Decoder s ()
checkSize Int
2 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TxIn -> TxValidationError
TxValidationMissingInput forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
5 -> forall s. Int -> Decoder s ()
checkSize Int
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> NetworkMagic -> NetworkMagic -> TxValidationError
TxValidationNetworkMagicMismatch forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
6 -> forall s. Int -> Decoder s ()
checkSize Int
3 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Natural -> Natural -> TxValidationError
TxValidationTxTooLarge forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
7 -> forall s. Int -> Decoder s ()
checkSize Int
1 forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> TxValidationError
TxValidationUnknownAddressAttributes
      Word8
8 -> forall s. Int -> Decoder s ()
checkSize Int
1 forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> TxValidationError
TxValidationUnknownAttributes
      Word8
_ -> forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> Word8 -> DecoderError
DecoderErrorUnknownTag Text
"TxValidationError" Word8
tag

-- | Validate that:
--
--   1. The fee for a transaction is not less than the minimum fee.
--   2. The size of the transaction is below the maximum size.
--   3. Output balance + fee = input balance
--
--   The transaction size must be calculated _including the witnesses_. As such
--   this cannot be part of 'validateTx'. We actually assume 3 by calculating
--   the fee as output balance - input balance.
validateTxAux ::
  MonadError TxValidationError m =>
  Environment ->
  UTxO ->
  ATxAux ByteString ->
  m ()
validateTxAux :: forall (m :: * -> *).
MonadError TxValidationError m =>
Environment -> UTxO -> ATxAux ByteString -> m ()
validateTxAux Environment
env UTxO
utxo (ATxAux (Annotated Tx
tx ByteString
_) Annotated TxWitness ByteString
_ ByteString
txBytes) = do
  -- Check that the size of the transaction is less than the maximum
  Natural
txSize
    forall a. Ord a => a -> a -> Bool
<= Natural
maxTxSize
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` Natural -> Natural -> TxValidationError
TxValidationTxTooLarge Natural
txSize Natural
maxTxSize

  -- Calculate the minimum fee from the 'TxFeePolicy'
  Lovelace
minFee <-
    if UTxO -> Bool
isRedeemUTxO UTxO
inputUTxO
      then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (n :: Natural).
(KnownNat n, n <= 45000000000000000) =>
Lovelace
mkKnownLovelace @0
      else forall (m :: * -> *).
MonadError TxValidationError m =>
TxFeePolicy -> m Lovelace
calculateMinimumFee TxFeePolicy
feePolicy

  -- Calculate the balance of the output 'UTxO'
  Lovelace
balanceOut <-
    UTxO -> Either LovelaceError Lovelace
balance (Tx -> UTxO
txOutputUTxO Tx
tx)
      forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` Text -> LovelaceError -> TxValidationError
TxValidationLovelaceError Text
"Output Balance"

  -- Calculate the balance of the restricted input 'UTxO'
  Lovelace
balanceIn <-
    UTxO -> Either LovelaceError Lovelace
balance UTxO
inputUTxO
      forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` Text -> LovelaceError -> TxValidationError
TxValidationLovelaceError Text
"Input Balance"

  -- Calculate the 'fee' as the difference of the balances
  Lovelace
fee <-
    Lovelace -> Lovelace -> Either LovelaceError Lovelace
subLovelace Lovelace
balanceIn Lovelace
balanceOut
      forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` Text -> LovelaceError -> TxValidationError
TxValidationLovelaceError Text
"Fee"

  -- Check that the fee is greater than the minimum
  (Lovelace
minFee forall a. Ord a => a -> a -> Bool
<= Lovelace
fee) forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` Tx -> Lovelace -> Lovelace -> TxValidationError
TxValidationFeeTooSmall Tx
tx Lovelace
minFee Lovelace
fee
  where
    Environment {ProtocolParameters
protocolParameters :: Environment -> ProtocolParameters
protocolParameters :: ProtocolParameters
protocolParameters} = Environment
env

    maxTxSize :: Natural
maxTxSize = ProtocolParameters -> Natural
ppMaxTxSize ProtocolParameters
protocolParameters
    feePolicy :: TxFeePolicy
feePolicy = ProtocolParameters -> TxFeePolicy
ppTxFeePolicy ProtocolParameters
protocolParameters

    txSize :: Natural
    txSize :: Natural
txSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
txBytes

    inputUTxO :: UTxO
inputUTxO = forall a. Ord a => [a] -> Set a
S.fromList (forall a. NonEmpty a -> [a]
NE.toList (Tx -> NonEmpty TxIn
txInputs Tx
tx)) Set TxIn -> UTxO -> UTxO
<| UTxO
utxo

    calculateMinimumFee ::
      MonadError TxValidationError m => TxFeePolicy -> m Lovelace
    calculateMinimumFee :: forall (m :: * -> *).
MonadError TxValidationError m =>
TxFeePolicy -> m Lovelace
calculateMinimumFee = \case
      TxFeePolicyTxSizeLinear TxSizeLinear
txSizeLinear ->
        TxSizeLinear -> Natural -> Either LovelaceError Lovelace
calculateTxSizeLinear TxSizeLinear
txSizeLinear Natural
txSize
          forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` Text -> LovelaceError -> TxValidationError
TxValidationLovelaceError Text
"Minimum Fee"

-- | Validate that:
--
--   1. All @TxIn@s are in domain of @Utxo@
--
--   These are the conditions of the UTxO inference rule in the spec.
validateTx ::
  MonadError TxValidationError m =>
  Environment ->
  UTxO ->
  Annotated Tx ByteString ->
  m ()
validateTx :: forall (m :: * -> *).
MonadError TxValidationError m =>
Environment -> UTxO -> Annotated Tx ByteString -> m ()
validateTx Environment
env UTxO
utxo (Annotated Tx
tx ByteString
_) = do
  -- Check that the transaction attributes are less than the max size
  forall a. Attributes a -> Int
unknownAttributesLength (Tx -> TxAttributes
txAttributes Tx
tx)
    forall a. Ord a => a -> a -> Bool
< Int
128
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` TxValidationError
TxValidationUnknownAttributes

  -- Check that outputs have valid NetworkMagic
  let nm :: NetworkMagic
nm = forall a. AProtocolMagic a -> NetworkMagic
makeNetworkMagic AProtocolMagic ByteString
protocolMagic
  Tx -> NonEmpty TxOut
txOutputs Tx
tx forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` forall (m :: * -> *).
MonadError TxValidationError m =>
NetworkMagic -> TxOut -> m ()
validateTxOutNM NetworkMagic
nm

  -- Check that every input is in the domain of 'utxo'
  Tx -> NonEmpty TxIn
txInputs Tx
tx forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
`forM_` forall (m :: * -> *).
MonadError TxValidationError m =>
UTxOConfiguration -> UTxO -> TxIn -> m ()
validateTxIn UTxOConfiguration
utxoConfiguration UTxO
utxo
  where
    Environment {AProtocolMagic ByteString
protocolMagic :: Environment -> AProtocolMagic ByteString
protocolMagic :: AProtocolMagic ByteString
protocolMagic, UTxOConfiguration
utxoConfiguration :: Environment -> UTxOConfiguration
utxoConfiguration :: UTxOConfiguration
utxoConfiguration} = Environment
env

-- | Validate that 'TxIn' is in the domain of 'UTxO'
validateTxIn ::
  MonadError TxValidationError m =>
  UTxOConfiguration ->
  UTxO ->
  TxIn ->
  m ()
validateTxIn :: forall (m :: * -> *).
MonadError TxValidationError m =>
UTxOConfiguration -> UTxO -> TxIn -> m ()
validateTxIn UTxOConfiguration {Set CompactAddress
tcAssetLockedSrcAddrs :: UTxOConfiguration -> Set CompactAddress
tcAssetLockedSrcAddrs :: Set CompactAddress
tcAssetLockedSrcAddrs} UTxO
utxo TxIn
txIn
  | forall a. Set a -> Bool
S.null Set CompactAddress
tcAssetLockedSrcAddrs
  , TxIn
txIn TxIn -> UTxO -> Bool
`UTxO.member` UTxO
utxo =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Just CompactTxOut
txOut <- CompactTxIn -> UTxO -> Maybe CompactTxOut
UTxO.lookupCompact (TxIn -> CompactTxIn
toCompactTxIn TxIn
txIn) UTxO
utxo
  , let (CompactTxOut CompactAddress
txOutAddr Lovelace
_) = CompactTxOut
txOut
  , CompactAddress
txOutAddr forall a. Ord a => a -> Set a -> Bool
`S.notMember` Set CompactAddress
tcAssetLockedSrcAddrs =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise =
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ TxIn -> TxValidationError
TxValidationMissingInput TxIn
txIn

-- | Validate the NetworkMagic of a TxOut
validateTxOutNM ::
  MonadError TxValidationError m =>
  NetworkMagic ->
  TxOut ->
  m ()
validateTxOutNM :: forall (m :: * -> *).
MonadError TxValidationError m =>
NetworkMagic -> TxOut -> m ()
validateTxOutNM NetworkMagic
nm TxOut
txOut = do
  -- Make sure that the unknown attributes are less than the max size
  forall a. Attributes a -> Int
unknownAttributesLength (Address -> Attributes AddrAttributes
addrAttributes (TxOut -> Address
txOutAddress TxOut
txOut))
    forall a. Ord a => a -> a -> Bool
< Int
128
    forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` TxValidationError
TxValidationUnknownAddressAttributes

  -- Check that the network magic in the address matches the expected one
  (NetworkMagic
nm forall a. Eq a => a -> a -> Bool
== NetworkMagic
addrNm) forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` NetworkMagic -> NetworkMagic -> TxValidationError
TxValidationNetworkMagicMismatch NetworkMagic
nm NetworkMagic
addrNm
  where
    addrNm :: NetworkMagic
addrNm = Address -> NetworkMagic
addrNetworkMagic forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. TxOut -> Address
txOutAddress forall a b. (a -> b) -> a -> b
$ TxOut
txOut

-- | Verify that a 'TxInWitness' is a valid witness for the supplied 'TxSigData'
validateWitness ::
  MonadError TxValidationError m =>
  Annotated ProtocolMagicId ByteString ->
  Annotated TxSigData ByteString ->
  Address ->
  TxInWitness ->
  m ()
validateWitness :: forall (m :: * -> *).
MonadError TxValidationError m =>
Annotated ProtocolMagicId ByteString
-> Annotated TxSigData ByteString -> Address -> TxInWitness -> m ()
validateWitness Annotated ProtocolMagicId ByteString
pmi Annotated TxSigData ByteString
sigData Address
addr TxInWitness
witness = case TxInWitness
witness of
  VKWitness VerificationKey
vk TxSig
sig -> do
    forall t.
Decoded t =>
Annotated ProtocolMagicId ByteString
-> SignTag
-> VerificationKey
-> t
-> Signature (BaseType t)
-> Bool
verifySignatureDecoded Annotated ProtocolMagicId ByteString
pmi SignTag
SignTx VerificationKey
vk Annotated TxSigData ByteString
sigData TxSig
sig
      forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` TxInWitness -> ProtocolMagicId -> TxSigData -> TxValidationError
TxValidationWitnessWrongSignature
        TxInWitness
witness
        (forall b a. Annotated b a -> b
unAnnotated Annotated ProtocolMagicId ByteString
pmi)
        (forall b a. Annotated b a -> b
unAnnotated Annotated TxSigData ByteString
sigData)
    VerificationKey -> Address -> Bool
checkVerKeyAddress VerificationKey
vk Address
addr
      forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` TxInWitness -> Address -> TxValidationError
TxValidationWitnessWrongKey
        TxInWitness
witness
        Address
addr
  RedeemWitness RedeemVerificationKey
vk RedeemSignature TxSigData
sig -> do
    forall t.
Decoded t =>
Annotated ProtocolMagicId ByteString
-> SignTag
-> RedeemVerificationKey
-> t
-> RedeemSignature (BaseType t)
-> Bool
verifyRedeemSigDecoded Annotated ProtocolMagicId ByteString
pmi SignTag
SignRedeemTx RedeemVerificationKey
vk Annotated TxSigData ByteString
sigData RedeemSignature TxSigData
sig
      forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` TxInWitness -> ProtocolMagicId -> TxSigData -> TxValidationError
TxValidationWitnessWrongSignature
        TxInWitness
witness
        (forall b a. Annotated b a -> b
unAnnotated Annotated ProtocolMagicId ByteString
pmi)
        (forall b a. Annotated b a -> b
unAnnotated Annotated TxSigData ByteString
sigData)
    RedeemVerificationKey -> Address -> Bool
checkRedeemAddress RedeemVerificationKey
vk Address
addr
      forall e (m :: * -> *). MonadError e m => Bool -> e -> m ()
`orThrowError` TxInWitness -> Address -> TxValidationError
TxValidationWitnessWrongKey TxInWitness
witness Address
addr

data Environment = Environment
  { Environment -> AProtocolMagic ByteString
protocolMagic :: !(AProtocolMagic ByteString)
  , Environment -> ProtocolParameters
protocolParameters :: !ProtocolParameters
  , Environment -> UTxOConfiguration
utxoConfiguration :: !UTxOConfiguration
  }
  deriving (Environment -> Environment -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Environment -> Environment -> Bool
$c/= :: Environment -> Environment -> Bool
== :: Environment -> Environment -> Bool
$c== :: Environment -> Environment -> Bool
Eq, Int -> Environment -> ShowS
[Environment] -> ShowS
Environment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Environment] -> ShowS
$cshowList :: [Environment] -> ShowS
show :: Environment -> String
$cshow :: Environment -> String
showsPrec :: Int -> Environment -> ShowS
$cshowsPrec :: Int -> Environment -> ShowS
Show)

data UTxOValidationError
  = UTxOValidationTxValidationError TxValidationError
  | UTxOValidationUTxOError UTxOError
  deriving (UTxOValidationError -> UTxOValidationError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UTxOValidationError -> UTxOValidationError -> Bool
$c/= :: UTxOValidationError -> UTxOValidationError -> Bool
== :: UTxOValidationError -> UTxOValidationError -> Bool
$c== :: UTxOValidationError -> UTxOValidationError -> Bool
Eq, Int -> UTxOValidationError -> ShowS
[UTxOValidationError] -> ShowS
UTxOValidationError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UTxOValidationError] -> ShowS
$cshowList :: [UTxOValidationError] -> ShowS
show :: UTxOValidationError -> String
$cshow :: UTxOValidationError -> String
showsPrec :: Int -> UTxOValidationError -> ShowS
$cshowsPrec :: Int -> UTxOValidationError -> ShowS
Show)

instance ToCBOR UTxOValidationError where
  toCBOR :: UTxOValidationError -> Encoding
toCBOR = forall a. EncCBOR a => a -> Encoding
toByronCBOR

instance FromCBOR UTxOValidationError where
  fromCBOR :: forall s. Decoder s UTxOValidationError
fromCBOR = forall a s. DecCBOR a => Decoder s a
fromByronCBOR

instance EncCBOR UTxOValidationError where
  encCBOR :: UTxOValidationError -> Encoding
encCBOR = \case
    UTxOValidationTxValidationError TxValidationError
txValidationError ->
      Word -> Encoding
encodeListLen Word
2 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR @Word8 Word8
0 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR TxValidationError
txValidationError
    UTxOValidationUTxOError UTxOError
uTxOError ->
      Word -> Encoding
encodeListLen Word
2 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR @Word8 Word8
1 forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR UTxOError
uTxOError

instance DecCBOR UTxOValidationError where
  decCBOR :: forall s. Decoder s UTxOValidationError
decCBOR = do
    forall s. Text -> Int -> Decoder s ()
enforceSize Text
"UTxOValidationError" Int
2
    forall s. Decoder s Word8
decodeWord8 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Word8
0 -> TxValidationError -> UTxOValidationError
UTxOValidationTxValidationError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
1 -> UTxOError -> UTxOValidationError
UTxOValidationUTxOError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR
      Word8
tag -> forall (m :: * -> *) e a. (MonadFail m, Buildable e) => e -> m a
cborError forall a b. (a -> b) -> a -> b
$ Text -> Word8 -> DecoderError
DecoderErrorUnknownTag Text
"UTxOValidationError" Word8
tag

-- | Validate a transaction and use it to update the 'UTxO'
updateUTxOTx ::
  (MonadError UTxOValidationError m, MonadReader ValidationMode m) =>
  Environment ->
  UTxO ->
  Annotated Tx ByteString ->
  m UTxO
updateUTxOTx :: forall (m :: * -> *).
(MonadError UTxOValidationError m, MonadReader ValidationMode m) =>
Environment -> UTxO -> Annotated Tx ByteString -> m UTxO
updateUTxOTx Environment
env UTxO
utxo aTx :: Annotated Tx ByteString
aTx@(Annotated Tx
tx ByteString
_) = do
  forall err (m :: * -> *).
(MonadError err m, MonadReader ValidationMode m) =>
m () -> m ()
unlessNoTxValidation (forall (m :: * -> *).
MonadError TxValidationError m =>
Environment -> UTxO -> Annotated Tx ByteString -> m ()
validateTx Environment
env UTxO
utxo Annotated Tx ByteString
aTx)
    forall e' (m :: * -> *) e a.
(MonadError e' m, MonadReader ValidationMode m) =>
ReaderT ValidationMode (Either e) a -> (e -> e') -> m a
`wrapErrorWithValidationMode` TxValidationError -> UTxOValidationError
UTxOValidationTxValidationError

  forall (m :: * -> *).
MonadError UTxOError m =>
UTxO -> UTxO -> m UTxO
UTxO.union (forall a. Ord a => [a] -> Set a
S.fromList (forall a. NonEmpty a -> [a]
NE.toList (Tx -> NonEmpty TxIn
txInputs Tx
tx)) Set TxIn -> UTxO -> UTxO
</| UTxO
utxo) (Tx -> UTxO
txOutputUTxO Tx
tx)
    forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` UTxOError -> UTxOValidationError
UTxOValidationUTxOError

-- | Validate a transaction with a witness and use it to update the 'UTxO'
updateUTxOTxWitness ::
  (MonadError UTxOValidationError m, MonadReader ValidationMode m) =>
  Environment ->
  UTxO ->
  ATxAux ByteString ->
  m UTxO
updateUTxOTxWitness :: forall (m :: * -> *).
(MonadError UTxOValidationError m, MonadReader ValidationMode m) =>
Environment -> UTxO -> ATxAux ByteString -> m UTxO
updateUTxOTxWitness Environment
env UTxO
utxo ATxAux ByteString
ta = do
  forall err (m :: * -> *).
(MonadError err m, MonadReader ValidationMode m) =>
m () -> m ()
whenTxValidation forall a b. (a -> b) -> a -> b
$ do
    -- Get the signing addresses for each transaction input from the 'UTxO'
    [Address]
addresses <-
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TxIn -> UTxO -> Either UTxOError Address
`UTxO.lookupAddress` UTxO
utxo) (forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$ Tx -> NonEmpty TxIn
txInputs Tx
tx)
        forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` UTxOError -> UTxOValidationError
UTxOValidationUTxOError

    -- Validate witnesses and their signing addresses
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
      (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadError TxValidationError m =>
Annotated ProtocolMagicId ByteString
-> Annotated TxSigData ByteString -> Address -> TxInWitness -> m ()
validateWitness Annotated ProtocolMagicId ByteString
pmi Annotated TxSigData ByteString
sigData)
      (forall a b. [a] -> [b] -> [(a, b)]
zip [Address]
addresses (forall a. Vector a -> [a]
V.toList TxWitness
witness))
      forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` TxValidationError -> UTxOValidationError
UTxOValidationTxValidationError

    -- Validate the tx including witnesses
    forall (m :: * -> *).
MonadError TxValidationError m =>
Environment -> UTxO -> ATxAux ByteString -> m ()
validateTxAux Environment
env UTxO
utxo ATxAux ByteString
ta
      forall e' (m :: * -> *) e a.
MonadError e' m =>
Either e a -> (e -> e') -> m a
`wrapError` TxValidationError -> UTxOValidationError
UTxOValidationTxValidationError

  -- Update 'UTxO' ignoring witnesses
  forall (m :: * -> *).
(MonadError UTxOValidationError m, MonadReader ValidationMode m) =>
Environment -> UTxO -> Annotated Tx ByteString -> m UTxO
updateUTxOTx Environment
env UTxO
utxo Annotated Tx ByteString
aTx
  where
    Environment {AProtocolMagic ByteString
protocolMagic :: AProtocolMagic ByteString
protocolMagic :: Environment -> AProtocolMagic ByteString
protocolMagic} = Environment
env
    pmi :: Annotated ProtocolMagicId ByteString
pmi = forall a. AProtocolMagic a -> Annotated ProtocolMagicId a
getAProtocolMagicId AProtocolMagic ByteString
protocolMagic

    aTx :: Annotated Tx ByteString
aTx@(Annotated Tx
tx ByteString
_) = forall a. ATxAux a -> Annotated Tx a
aTaTx ATxAux ByteString
ta
    witness :: TxWitness
witness = forall a. ATxAux a -> TxWitness
taWitness ATxAux ByteString
ta
    sigData :: Annotated TxSigData ByteString
sigData = Annotated Tx ByteString -> Annotated TxSigData ByteString
recoverSigData Annotated Tx ByteString
aTx

-- | Update UTxO with a list of transactions
updateUTxO ::
  (MonadError UTxOValidationError m, MonadReader ValidationMode m) =>
  Environment ->
  UTxO ->
  [ATxAux ByteString] ->
  m UTxO
updateUTxO :: forall (m :: * -> *).
(MonadError UTxOValidationError m, MonadReader ValidationMode m) =>
Environment -> UTxO -> [ATxAux ByteString] -> m UTxO
updateUTxO Environment
env UTxO
as = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (forall (m :: * -> *).
(MonadError UTxOValidationError m, MonadReader ValidationMode m) =>
Environment -> UTxO -> ATxAux ByteString -> m UTxO
updateUTxOTxWitness Environment
env) UTxO
as