{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

{- | Threat model for detecting Token Forgery vulnerabilities.

A Token Forgery Attack exploits minting policies that are too permissive.
If a minting policy allows tokens to be minted under weak conditions (e.g.,
just requiring any signature), an attacker can mint unauthorized tokens.

== Vulnerability Pattern ==

A vulnerable minting policy might only check:

@
MintValidation -> {
  // VULNERABLE: Anyone who signs can mint!
  list.length(self.extra_signatories) > 0
}
@

This is trivially satisfied by ANY signed transaction, allowing anyone to
forge tokens that should be restricted.

== Consequences ==

1. __Validation token bypass__: If a validator requires a "validation token"
   to prove authorization, attackers can mint their own tokens.

2. __Asset theft__: Forged tokens can be used to satisfy validator checks,
   potentially draining funds.

3. __Protocol manipulation__: In DeFi protocols, forged governance or
   utility tokens can manipulate voting, rewards, or access control.

== Mitigation ==

A secure minting policy should:

- Require specific authorized signers (not just "any signature")
- Check that minting is authorized by a governance mechanism
- Verify minting is part of a valid protocol operation
- Use one-shot minting for unique tokens (NFTs, thread tokens)

'tokenForgeryAttack' tests if additional tokens can be minted using a minting
policy the transaction under test already exercises, reusing the same
redeemer. If the transaction still validates with the extra minted tokens,
that minting policy is too permissive. Use 'tokenForgeryAttackWith' to test a
specific policy instead (e.g. one the transaction doesn't otherwise use).
-}
module Convex.ThreatModel.TokenForgery (
  -- * Threat models
  tokenForgeryAttack,
  tokenForgeryAttackWith,
) where

import Cardano.Api qualified as C
import Convex.ThreatModel
import Convex.ThreatModel.Cardano.Api (IsPlutusScriptInEra, mintedPlutusPolicies)
import Convex.ThreatModel.TxModifier (addPlutusScriptMint)
import GHC.Exts (fromList, toList)

{- | Check for Token Forgery vulnerabilities against a minting policy the transaction
under test already exercises.

For every Plutus minting policy the transaction mints a positive quantity under,
resolved from its own witness set or a reference-script UTxO, this picks one such
policy/asset pair and attempts to mint one additional unit of that asset under the
same policy with the same redeemer the transaction already used. If the modified
transaction still validates, the minting policy accepted more than it authorized.

Skips (via 'threatPrecondition') transactions that don't mint under any resolvable
Plutus policy. Use 'tokenForgeryAttackWith' to test a specific policy instead,
e.g. one unrelated to anything the transaction does.
-}
tokenForgeryAttack :: ThreatModel ()
tokenForgeryAttack :: ThreatModel ()
tokenForgeryAttack = String -> ThreatModel () -> ThreatModel ()
forall a. String -> ThreatModel a -> ThreatModel a
Named String
"Token Forgery Attack" (ThreatModel () -> ThreatModel ())
-> ThreatModel () -> ThreatModel ()
forall a b. (a -> b) -> a -> b
$ do
  Tx Era
tx <- ThreatModel (Tx Era)
originalTx
  UTxO Era
utxos <- ThreatModelEnv -> UTxO Era
currentUTxOs (ThreatModelEnv -> UTxO Era)
-> ThreatModel ThreatModelEnv -> ThreatModel (UTxO Era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ThreatModel ThreatModelEnv
getThreatModelEnv
  let candidates :: [(AssetName, ScriptInAnyLang, ScriptData)]
candidates =
        [ (AssetName
assetName, ScriptInAnyLang
scriptInAnyLang, ScriptData
redeemer)
        | (PolicyId
_policyId, PolicyAssets
assets, ScriptInAnyLang
scriptInAnyLang, ScriptData
redeemer) <- Tx Era
-> UTxO Era
-> [(PolicyId, PolicyAssets, ScriptInAnyLang, ScriptData)]
mintedPlutusPolicies Tx Era
tx UTxO Era
utxos
        , (AssetName
assetName, Quantity
quantity) <- PolicyAssets -> [Item PolicyAssets]
forall l. IsList l => l -> [Item l]
toList PolicyAssets
assets
        , Quantity
quantity Quantity -> Quantity -> Bool
forall a. Ord a => a -> a -> Bool
> Quantity
0
        ]
  case [(AssetName, ScriptInAnyLang, ScriptData)]
candidates of
    [] -> String -> ThreatModel ()
forall a. String -> ThreatModel a
failPrecondition String
"Transaction does not mint any Plutus policy assets"
    [(AssetName, ScriptInAnyLang, ScriptData)]
_ -> do
      (AssetName
assetName, ScriptInAnyLang
scriptInAnyLang, ScriptData
redeemer) <- [(AssetName, ScriptInAnyLang, ScriptData)]
-> ThreatModel (AssetName, ScriptInAnyLang, ScriptData)
forall a. Show a => [a] -> ThreatModel a
pickAny [(AssetName, ScriptInAnyLang, ScriptData)]
candidates
      case ScriptInAnyLang
scriptInAnyLang of
        C.ScriptInAnyLang (C.PlutusScriptLanguage PlutusScriptVersion lang
C.PlutusScriptV1) (C.PlutusScript PlutusScriptVersion lang
_ PlutusScript lang
script) ->
          ScriptData -> PlutusScript lang -> AssetName -> ThreatModel ()
forall lang.
IsPlutusScriptInEra lang =>
ScriptData -> PlutusScript lang -> AssetName -> ThreatModel ()
mintExtraUnit ScriptData
redeemer PlutusScript lang
script AssetName
assetName
        C.ScriptInAnyLang (C.PlutusScriptLanguage PlutusScriptVersion lang
C.PlutusScriptV2) (C.PlutusScript PlutusScriptVersion lang
_ PlutusScript lang
script) ->
          ScriptData -> PlutusScript lang -> AssetName -> ThreatModel ()
forall lang.
IsPlutusScriptInEra lang =>
ScriptData -> PlutusScript lang -> AssetName -> ThreatModel ()
mintExtraUnit ScriptData
redeemer PlutusScript lang
script AssetName
assetName
        C.ScriptInAnyLang (C.PlutusScriptLanguage PlutusScriptVersion lang
C.PlutusScriptV3) (C.PlutusScript PlutusScriptVersion lang
_ PlutusScript lang
script) ->
          ScriptData -> PlutusScript lang -> AssetName -> ThreatModel ()
forall lang.
IsPlutusScriptInEra lang =>
ScriptData -> PlutusScript lang -> AssetName -> ThreatModel ()
mintExtraUnit ScriptData
redeemer PlutusScript lang
script AssetName
assetName
        ScriptInAnyLang
_ -> String -> ThreatModel ()
forall a. String -> ThreatModel a
failPrecondition String
"Minting policy is not a Plutus script (V1, V2, or V3)"

{- | Check for Token Forgery vulnerabilities with a specific minting policy and redeemer,
regardless of whether the transaction under test already uses it.

@
  -- Test with MintValidation redeemer (Constr 0 [])
  tokenForgeryAttackWith (ScriptDataConstructor 0 []) mintingPolicy assetName

  -- Test with custom redeemer
  tokenForgeryAttackWith myRedeemer mintingPolicy assetName
@
-}
tokenForgeryAttackWith
  :: (IsPlutusScriptInEra lang)
  => C.ScriptData
  -- ^ Redeemer for the minting policy
  -> C.PlutusScript lang
  -- ^ The minting policy to test
  -> C.AssetName
  -- ^ The asset name to mint
  -> ThreatModel ()
tokenForgeryAttackWith :: forall lang.
IsPlutusScriptInEra lang =>
ScriptData -> PlutusScript lang -> AssetName -> ThreatModel ()
tokenForgeryAttackWith ScriptData
redeemer PlutusScript lang
mintScript AssetName
assetName =
  String -> ThreatModel () -> ThreatModel ()
forall a. String -> ThreatModel a -> ThreatModel a
Named String
"Token Forgery Attack" (ThreatModel () -> ThreatModel ())
-> ThreatModel () -> ThreatModel ()
forall a b. (a -> b) -> a -> b
$ ScriptData -> PlutusScript lang -> AssetName -> ThreatModel ()
forall lang.
IsPlutusScriptInEra lang =>
ScriptData -> PlutusScript lang -> AssetName -> ThreatModel ()
mintExtraUnit ScriptData
redeemer PlutusScript lang
mintScript AssetName
assetName

mintExtraUnit :: (IsPlutusScriptInEra lang) => C.ScriptData -> C.PlutusScript lang -> C.AssetName -> ThreatModel ()
mintExtraUnit :: forall lang.
IsPlutusScriptInEra lang =>
ScriptData -> PlutusScript lang -> AssetName -> ThreatModel ()
mintExtraUnit ScriptData
redeemer PlutusScript lang
mintScript AssetName
assetName = do
  -- Find an output to add the minted tokens to
  -- Prefer a key address output (like the change output)
  Output
output <- (Output -> Bool) -> ThreatModel Output
anyOutputSuchThat (AddressAny -> Bool
isKeyAddressAny (AddressAny -> Bool) -> (Output -> AddressAny) -> Output -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Output -> AddressAny
forall t. IsInputOrOutput t => t -> AddressAny
addressOf)

  String -> ThreatModel ()
counterexampleTM (String -> ThreatModel ()) -> String -> ThreatModel ()
forall a b. (a -> b) -> a -> b
$
    [String] -> String
paragraph
      [ String
"Testing Token Forgery vulnerability:"
      , String
"Attempting to mint additional tokens using the provided minting policy."
      , String
"Adding minted tokens to output at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
forall a. Show a => a -> String
show (AddressAny -> Doc
prettyAddress (AddressAny -> Doc) -> AddressAny -> Doc
forall a b. (a -> b) -> a -> b
$ Output -> AddressAny
forall t. IsInputOrOutput t => t -> AddressAny
addressOf Output
output) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"."
      ]

  String -> ThreatModel ()
counterexampleTM (String -> ThreatModel ()) -> String -> ThreatModel ()
forall a b. (a -> b) -> a -> b
$
    [String] -> String
paragraph
      [ String
"If this validates, the minting policy is too permissive."
      , String
"An attacker could forge tokens to:"
      , String
"1) Bypass validation token requirements"
      , String
"2) Steal assets protected by token checks"
      , String
"3) Manipulate protocol state"
      ]

  -- Calculate the minted asset value
  let scriptHash :: ScriptHash
scriptHash = Script lang -> ScriptHash
forall lang. Script lang -> ScriptHash
C.hashScript (Script lang -> ScriptHash) -> Script lang -> ScriptHash
forall a b. (a -> b) -> a -> b
$ PlutusScriptVersion lang -> PlutusScript lang -> Script lang
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScriptVersion lang -> PlutusScript lang -> Script lang
C.PlutusScript PlutusScriptVersion lang
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScriptVersion lang
plutusScriptVersion PlutusScript lang
mintScript
      policyId :: PolicyId
policyId = ScriptHash -> PolicyId
C.PolicyId ScriptHash
scriptHash
      mintedValue :: Value
mintedValue = [Item Value] -> Value
forall l. IsList l => [Item l] -> l
fromList [(PolicyId -> AssetName -> AssetId
C.AssetId PolicyId
policyId AssetName
assetName, Quantity
1)]
      valueWithForgedToken :: Value
valueWithForgedToken = Output -> Value
forall t. IsInputOrOutput t => t -> Value
valueOf Output
output Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
mintedValue

  -- Top up ADA to the new min-UTxO requirement. Without this, adding a brand
  -- new asset to the output can push it below the min-UTxO for its (now
  -- larger) value, tripping BabbageOutputTooSmallUTxO in Phase 1 before the
  -- minting policy is ever exercised -- silently defeating the attack.
  LedgerProtocolParameters Era
envPParams <- ThreatModelEnv -> LedgerProtocolParameters Era
pparams (ThreatModelEnv -> LedgerProtocolParameters Era)
-> ThreatModel ThreatModelEnv
-> ThreatModel (LedgerProtocolParameters Era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ThreatModel ThreatModelEnv
getThreatModelEnv
  let C.TxOut AddressInEra Era
outAddr TxOutValue Era
_ TxOutDatum CtxTx Era
outDatum ReferenceScript Era
outRefScript = Output -> TxOut CtxTx Era
outputTxOut Output
output
      candidateTxOut :: TxOut CtxTx Era
candidateTxOut =
        AddressInEra Era
-> TxOutValue Era
-> TxOutDatum CtxTx Era
-> ReferenceScript Era
-> TxOut CtxTx Era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
C.TxOut
          AddressInEra Era
outAddr
          (ShelleyBasedEra Era
-> Value (ShelleyLedgerEra Era) -> TxOutValue Era
forall era.
(Eq (Value (ShelleyLedgerEra era)),
 Show (Value (ShelleyLedgerEra era))) =>
ShelleyBasedEra era
-> Value (ShelleyLedgerEra era) -> TxOutValue era
C.TxOutValueShelleyBased ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
C.shelleyBasedEra (Value -> MaryValue
C.toMaryValue Value
valueWithForgedToken))
          TxOutDatum CtxTx Era
outDatum
          ReferenceScript Era
outRefScript
      minCoin :: Coin
minCoin = ShelleyBasedEra Era
-> PParams (ShelleyLedgerEra Era) -> TxOut CtxTx Era -> Coin
forall era.
HasCallStack =>
ShelleyBasedEra era
-> PParams (ShelleyLedgerEra era) -> TxOut CtxTx era -> Coin
C.calculateMinimumUTxO ShelleyBasedEra Era
forall era. IsShelleyBasedEra era => ShelleyBasedEra era
C.shelleyBasedEra (LedgerProtocolParameters Era -> PParams (ShelleyLedgerEra Era)
forall era.
LedgerProtocolParameters era -> PParams (ShelleyLedgerEra era)
C.unLedgerProtocolParameters LedgerProtocolParameters Era
envPParams) TxOut CtxTx Era
candidateTxOut
      shortfall :: Coin
shortfall = Coin
minCoin Coin -> Coin -> Coin
forall a. Num a => a -> a -> a
- Value -> Coin
C.selectLovelace Value
valueWithForgedToken
      newValue :: Value
newValue
        | Coin
shortfall Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
> Coin
0 = Value
valueWithForgedToken Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Coin -> Value
C.lovelaceToValue Coin
shortfall
        | Bool
otherwise = Value
valueWithForgedToken

  -- Try to mint one additional token with the given policy and add it to the output
  -- This SHOULD fail - if it validates, the policy is vulnerable
  TxModifier -> ThreatModel ()
shouldNotValidate (TxModifier -> ThreatModel ()) -> TxModifier -> ThreatModel ()
forall a b. (a -> b) -> a -> b
$
    Output -> Value -> TxModifier
forall t. IsInputOrOutput t => t -> Value -> TxModifier
changeValueOf Output
output Value
newValue
      TxModifier -> TxModifier -> TxModifier
forall a. Semigroup a => a -> a -> a
<> PlutusScript lang
-> AssetName -> Quantity -> ScriptData -> TxModifier
forall lang.
IsPlutusScriptInEra lang =>
PlutusScript lang
-> AssetName -> Quantity -> ScriptData -> TxModifier
addPlutusScriptMint PlutusScript lang
mintScript AssetName
assetName (Integer -> Quantity
C.Quantity Integer
1) ScriptData
redeemer