{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

{- | Threat model for detecting input ordering bypass vulnerabilities.

Some Plutus validators have logic like:
@
  or {
    own_ref != first_script_input_ref,  -- If NOT first → skip check!
    actual_validation_logic(...)        -- Only verified for first input
  }
@

This pattern is vulnerable because when multiple script inputs are spent
in one transaction, only the FIRST input is properly validated. An attacker
can add a second input from the same script which bypasses all validation.

This is particularly dangerous for:
- Lending protocols (second loan bypasses payment verification)
- Multi-signature schemes (second input bypasses signature checks)
- Any validator that assumes it's the only script input
-}
module Convex.ThreatModel.InputDuplication (
  inputDuplication,
) where

import Cardano.Api qualified as C
import Cardano.Ledger.Alonzo.Scripts qualified as Ledger
import Cardano.Ledger.Plutus.Language qualified as Plutus
import Data.Map qualified as Map
import Data.Maybe (mapMaybe)

import Convex.ThreatModel
import Convex.ThreatModel.Cardano.Api (Era, IsPlutusScriptInEra)

-- | A Plutus script that can be either V2 or V3
data SomePlutusScript where
  SomePlutusScript :: (IsPlutusScriptInEra lang) => C.PlutusScript lang -> SomePlutusScript

{- | Check for input duplication / input ordering bypass vulnerabilities.

For a transaction that spends from a script address:

1. Find a script input in the transaction
2. Look in the UTxO set for OTHER UTxOs at the same script address that aren't already spent
3. Add one of those as an additional input with the same redeemer
4. If the transaction still validates, the script has an input ordering vulnerability

The attack works because many scripts only validate the FIRST script input,
allowing subsequent inputs to bypass validation entirely.

Note: This threat model requires that there exist multiple UTxOs at the same
script address in the UTxO set. The test will be skipped if no additional
UTxOs are available.
-}
inputDuplication :: ThreatModel ()
inputDuplication :: ThreatModel ()
inputDuplication = String -> ThreatModel () -> ThreatModel ()
forall a. String -> ThreatModel a -> ThreatModel a
Named String
"Input Duplication" (ThreatModel () -> ThreatModel ())
-> ThreatModel () -> ThreatModel ()
forall a b. (a -> b) -> a -> b
$ do
  -- Get the environment to access the full UTxO set and the original transaction
  ThreatModelEnv Tx Era
tx (C.UTxO Map TxIn (TxOut CtxUTxO Era)
utxoMap) LedgerProtocolParameters Era
_ <- ThreatModel ThreatModelEnv
getThreatModelEnv

  -- Find a script input (non-key address = script address)
  Input
scriptInput <- (Input -> Bool) -> ThreatModel Input
anyInputSuchThat (Bool -> Bool
not (Bool -> Bool) -> (Input -> Bool) -> Input -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddressAny -> Bool
isKeyAddressAny (AddressAny -> Bool) -> (Input -> AddressAny) -> Input -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Input -> AddressAny
forall t. IsInputOrOutput t => t -> AddressAny
addressOf)
  let scriptAddr :: AddressAny
scriptAddr = Input -> AddressAny
forall t. IsInputOrOutput t => t -> AddressAny
addressOf Input
scriptInput
      existingTxIn :: TxIn
existingTxIn = Input -> TxIn
inputTxIn Input
scriptInput

  -- Get the redeemer for this input (we'll use the same for the new input)
  Redeemer
redeemer <-
    Input -> ThreatModel (Maybe Redeemer)
getRedeemer Input
scriptInput ThreatModel (Maybe Redeemer)
-> (Maybe Redeemer -> ThreatModel Redeemer) -> ThreatModel Redeemer
forall a b. ThreatModel a -> (a -> ThreatModel b) -> ThreatModel b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Redeemer
Nothing -> String -> ThreatModel Redeemer
forall a. String -> ThreatModel a
failPrecondition String
"Script input missing redeemer"
      Just Redeemer
redeemer' -> Redeemer -> ThreatModel Redeemer
forall a. a -> ThreatModel a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Redeemer
redeemer'

  -- Find OTHER UTxOs at the same script address that aren't already inputs
  [Input]
txInputsList <- ThreatModel [Input]
getTxInputs
  let existingInputTxIns :: [TxIn]
existingInputTxIns = (Input -> TxIn) -> [Input] -> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
map Input -> TxIn
inputTxIn [Input]
txInputsList

  let otherScriptUtxos :: [(TxIn, TxOut CtxUTxO Era)]
otherScriptUtxos =
        [ (TxIn
txIn, TxOut CtxUTxO Era
txOut)
        | (TxIn
txIn, TxOut CtxUTxO Era
txOut) <- Map TxIn (TxOut CtxUTxO Era) -> [(TxIn, TxOut CtxUTxO Era)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TxIn (TxOut CtxUTxO Era)
utxoMap
        , TxOut CtxUTxO Era -> AddressAny
addressOfTxOut' TxOut CtxUTxO Era
txOut AddressAny -> AddressAny -> Bool
forall a. Eq a => a -> a -> Bool
== AddressAny
scriptAddr
        , TxIn
txIn TxIn -> TxIn -> Bool
forall a. Eq a => a -> a -> Bool
/= TxIn
existingTxIn
        , TxIn
txIn TxIn -> [TxIn] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [TxIn]
existingInputTxIns
        ]

  -- Precondition: there must be another UTxO at the same script address
  ThreatModel () -> ThreatModel ()
forall a. ThreatModel a -> ThreatModel a
threatPrecondition (ThreatModel () -> ThreatModel ())
-> ThreatModel () -> ThreatModel ()
forall a b. (a -> b) -> a -> b
$ Bool -> ThreatModel ()
ensure (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(TxIn, TxOut CtxUTxO Era)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(TxIn, TxOut CtxUTxO Era)]
otherScriptUtxos)

  -- Pick one of the other UTxOs to add as an additional input
  (TxIn
newTxIn, TxOut CtxUTxO Era
newTxOut) <- [(TxIn, TxOut CtxUTxO Era)]
-> ThreatModel (TxIn, TxOut CtxUTxO Era)
forall a. Show a => [a] -> ThreatModel a
pickAny [(TxIn, TxOut CtxUTxO Era)]
otherScriptUtxos

  String -> ThreatModel ()
counterexampleTM (String -> ThreatModel ()) -> String -> ThreatModel ()
forall a b. (a -> b) -> a -> b
$
    [String] -> String
paragraph
      [ String
"The transaction spends a script UTxO at"
      , Doc -> String
forall a. Show a => a -> String
show (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ AddressAny -> Doc
prettyAddress AddressAny
scriptAddr
      ]

  String -> ThreatModel ()
counterexampleTM (String -> ThreatModel ()) -> String -> ThreatModel ()
forall a b. (a -> b) -> a -> b
$
    [String] -> String
paragraph
      [ String
"Found another UTxO at the same script address:"
      , TxIn -> String
forall a. Show a => a -> String
show TxIn
newTxIn
      , String
"Testing if adding this as an additional input bypasses validation."
      ]

  String -> ThreatModel ()
counterexampleTM (String -> ThreatModel ()) -> String -> ThreatModel ()
forall a b. (a -> b) -> a -> b
$
    [String] -> String
paragraph
      [ String
"If this validates, the script has an INPUT ORDERING BYPASS vulnerability."
      , String
"The validator only checks the first script input, allowing subsequent"
      , String
"inputs to bypass all validation logic (e.g., payment verification)."
      ]

  -- Get the datum from the new UTxO
  let newValue :: Value
newValue = TxOut CtxUTxO Era -> Value
valueOfTxOut' TxOut CtxUTxO Era
newTxOut
      newDatum :: Datum
newDatum = TxOut CtxUTxO Era -> Datum
extractDatum TxOut CtxUTxO Era
newTxOut

  -- Extract the script hash from the address
  let scriptHash :: ScriptHash
scriptHash = AddressAny -> ScriptHash
extractScriptHash AddressAny
scriptAddr

  -- Extract the actual script from the transaction's witness set
  -- This is needed to properly add the script to the new input's witness
  let scripts :: [AlonzoScript (ShelleyLedgerEra Era)]
scripts = Tx Era -> [AlonzoScript (ShelleyLedgerEra Era)]
extractTxScripts Tx Era
tx

  -- Get attacker address (one of the transaction signers) to receive stolen value
  Hash PaymentKey
signer <- ThreatModel (Hash PaymentKey)
anySigner
  let attackerAddr :: AddressAny
attackerAddr = Hash PaymentKey -> AddressAny
keyAddressAny Hash PaymentKey
signer
      -- Add output to attacker's address to conserve value (real attack scenario)
      attackerOutput :: TxModifier
attackerOutput = AddressAny -> Value -> Datum -> ReferenceScript Era -> TxModifier
addOutput AddressAny
attackerAddr Value
newValue Datum
forall ctx era. TxOutDatum ctx era
C.TxOutDatumNone ReferenceScript Era
forall era. ReferenceScript era
C.ReferenceScriptNone

  -- Try to find a Plutus script (V2 or V3) with the matching hash
  case ScriptHash
-> [AlonzoScript (ShelleyLedgerEra Era)] -> Maybe SomePlutusScript
findPlutusScriptByHash ScriptHash
scriptHash [AlonzoScript (ShelleyLedgerEra Era)]
scripts of
    Just (SomePlutusScript PlutusScript lang
plutusScript) -> do
      -- Add the new script input with the V2 script, plus attacker output
      TxModifier -> ThreatModel ()
shouldNotValidate (TxModifier -> ThreatModel ()) -> TxModifier -> ThreatModel ()
forall a b. (a -> b) -> a -> b
$
        PlutusScript lang
-> Value -> Datum -> Redeemer -> ReferenceScript Era -> TxModifier
forall lang.
IsPlutusScriptInEra lang =>
PlutusScript lang
-> Value -> Datum -> Redeemer -> ReferenceScript Era -> TxModifier
addPlutusScriptInput PlutusScript lang
plutusScript Value
newValue Datum
newDatum Redeemer
redeemer ReferenceScript Era
forall era. ReferenceScript era
C.ReferenceScriptNone
          TxModifier -> TxModifier -> TxModifier
forall a. Semigroup a => a -> a -> a
<> TxModifier
attackerOutput
    Maybe SomePlutusScript
Nothing ->
      -- Script not found in witness set - this shouldn't happen for a valid tx
      -- but if it does, we skip this test as a precondition failure
      String -> ThreatModel ()
forall a. String -> ThreatModel a
failPrecondition String
"Script not found in transaction witness set"
 where
  -- Helper to get address from TxOut CtxUTxO
  addressOfTxOut' :: C.TxOut C.CtxUTxO C.ConwayEra -> AddressAny
  addressOfTxOut' :: TxOut CtxUTxO Era -> AddressAny
addressOfTxOut' (C.TxOut (C.AddressInEra C.ShelleyAddressInEra{} Address addrtype
addr) TxOutValue Era
_ TxOutDatum CtxUTxO Era
_ ReferenceScript Era
_) = Address ShelleyAddr -> AddressAny
C.AddressShelley Address addrtype
Address ShelleyAddr
addr
  addressOfTxOut' (C.TxOut (C.AddressInEra C.ByronAddressInAnyEra{} Address addrtype
addr) TxOutValue Era
_ TxOutDatum CtxUTxO Era
_ ReferenceScript Era
_) = Address ByronAddr -> AddressAny
C.AddressByron Address addrtype
Address ByronAddr
addr

  -- Helper to get value from TxOut CtxUTxO
  valueOfTxOut' :: C.TxOut C.CtxUTxO C.ConwayEra -> C.Value
  valueOfTxOut' :: TxOut CtxUTxO Era -> Value
valueOfTxOut' (C.TxOut AddressInEra Era
_ TxOutValue Era
val TxOutDatum CtxUTxO Era
_ ReferenceScript Era
_) = TxOutValue Era -> Value
forall era. TxOutValue era -> Value
C.txOutValueToValue TxOutValue Era
val

  -- Extract datum from TxOut, converting to TxOutDatum CtxTx
  extractDatum :: C.TxOut C.CtxUTxO C.ConwayEra -> Datum
  extractDatum :: TxOut CtxUTxO Era -> Datum
extractDatum TxOut CtxUTxO Era
txOut = case TxOut CtxUTxO Era -> TxOutDatum CtxUTxO Era
forall ctx. TxOut ctx Era -> TxOutDatum ctx Era
datumOfTxOut TxOut CtxUTxO Era
txOut of
    TxOutDatum CtxUTxO Era
C.TxOutDatumNone -> Datum
forall ctx era. TxOutDatum ctx era
C.TxOutDatumNone
    C.TxOutDatumHash AlonzoEraOnwards Era
era Hash Redeemer
h -> AlonzoEraOnwards Era -> Hash Redeemer -> Datum
forall era ctx.
AlonzoEraOnwards era -> Hash Redeemer -> TxOutDatum ctx era
C.TxOutDatumHash AlonzoEraOnwards Era
era Hash Redeemer
h
    C.TxOutDatumInline BabbageEraOnwards Era
_era HashableScriptData
sd ->
      -- Convert inline datum to supplemental datum format for the new input
      -- Use AlonzoEraOnwardsConway for the SupplementalDatum era witness
      AlonzoEraOnwards Era -> HashableScriptData -> Datum
forall era.
AlonzoEraOnwards era -> HashableScriptData -> TxOutDatum CtxTx era
C.TxOutSupplementalDatum AlonzoEraOnwards Era
C.AlonzoEraOnwardsConway HashableScriptData
sd

  -- Extract script hash from a script address
  extractScriptHash :: AddressAny -> C.ScriptHash
  extractScriptHash :: AddressAny -> ScriptHash
extractScriptHash (C.AddressShelley Address ShelleyAddr
addr) =
    case Address ShelleyAddr -> Maybe PubKeyHash
C.shelleyPayAddrToPlutusPubKHash Address ShelleyAddr
addr of
      Maybe PubKeyHash
Nothing ->
        -- It's a script address, extract the hash
        case Address ShelleyAddr
addr of
          C.ShelleyAddress Network
_ PaymentCredential
cred StakeReference
_ ->
            case PaymentCredential -> PaymentCredential
C.fromShelleyPaymentCredential PaymentCredential
cred of
              C.PaymentCredentialByScript ScriptHash
h -> ScriptHash
h
              C.PaymentCredentialByKey Hash PaymentKey
_ -> String -> ScriptHash
forall a. HasCallStack => String -> a
error String
"Expected script address"
      Just PubKeyHash
_ -> String -> ScriptHash
forall a. HasCallStack => String -> a
error String
"Expected script address, got key address"
  extractScriptHash AddressAny
_ = String -> ScriptHash
forall a. HasCallStack => String -> a
error String
"Expected Shelley address"

  -- Extract the list of scripts from a transaction's witness set
  extractTxScripts :: C.Tx Era -> [Ledger.AlonzoScript (C.ShelleyLedgerEra Era)]
  extractTxScripts :: Tx Era -> [AlonzoScript (ShelleyLedgerEra Era)]
extractTxScripts (C.Tx (C.ShelleyTxBody ShelleyBasedEra Era
_ TxBody (ShelleyLedgerEra Era)
_ [Script (ShelleyLedgerEra Era)]
scripts TxBodyScriptData Era
_ Maybe (TxAuxData (ShelleyLedgerEra Era))
_ TxScriptValidity Era
_) [KeyWitness Era]
_) = [Script (ShelleyLedgerEra Era)]
[AlonzoScript (ShelleyLedgerEra Era)]
scripts

  -- Find a Plutus script (V2 or V3) by its hash in the list of ledger scripts
  findPlutusScriptByHash
    :: C.ScriptHash
    -> [Ledger.AlonzoScript (C.ShelleyLedgerEra Era)]
    -> Maybe SomePlutusScript
  findPlutusScriptByHash :: ScriptHash
-> [AlonzoScript (ShelleyLedgerEra Era)] -> Maybe SomePlutusScript
findPlutusScriptByHash ScriptHash
targetHash [AlonzoScript (ShelleyLedgerEra Era)]
scripts =
    case (AlonzoScript ConwayEra -> Maybe SomePlutusScript)
-> [AlonzoScript ConwayEra] -> [SomePlutusScript]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (ScriptHash
-> AlonzoScript (ShelleyLedgerEra Era) -> Maybe SomePlutusScript
tryConvertScript ScriptHash
targetHash) [AlonzoScript (ShelleyLedgerEra Era)]
[AlonzoScript ConwayEra]
scripts of
      (SomePlutusScript
s : [SomePlutusScript]
_) -> SomePlutusScript -> Maybe SomePlutusScript
forall a. a -> Maybe a
Just SomePlutusScript
s
      [] -> Maybe SomePlutusScript
forall a. Maybe a
Nothing

  -- Try to convert a ledger script to a SomePlutusScript if the hash matches
  tryConvertScript
    :: C.ScriptHash
    -> Ledger.AlonzoScript (C.ShelleyLedgerEra Era)
    -> Maybe SomePlutusScript
  tryConvertScript :: ScriptHash
-> AlonzoScript (ShelleyLedgerEra Era) -> Maybe SomePlutusScript
tryConvertScript ScriptHash
targetHash (Ledger.PlutusScript PlutusScript (ShelleyLedgerEra Era)
ps) =
    -- Use withPlutusScript to get the language at runtime
    PlutusScript ConwayEra
-> (forall {l :: Language}.
    PlutusLanguage l =>
    Plutus l -> Maybe SomePlutusScript)
-> Maybe SomePlutusScript
forall era a.
AlonzoEraScript era =>
PlutusScript era
-> (forall (l :: Language). PlutusLanguage l => Plutus l -> a) -> a
forall a.
PlutusScript ConwayEra
-> (forall (l :: Language). PlutusLanguage l => Plutus l -> a) -> a
Ledger.withPlutusScript PlutusScript (ShelleyLedgerEra Era)
PlutusScript ConwayEra
ps ((forall {l :: Language}.
  PlutusLanguage l =>
  Plutus l -> Maybe SomePlutusScript)
 -> Maybe SomePlutusScript)
-> (forall {l :: Language}.
    PlutusLanguage l =>
    Plutus l -> Maybe SomePlutusScript)
-> Maybe SomePlutusScript
forall a b. (a -> b) -> a -> b
$ \(Plutus l
plutus :: Plutus.Plutus l) ->
      let binaryBytes :: ShortByteString
binaryBytes = PlutusBinary -> ShortByteString
Plutus.unPlutusBinary (Plutus l -> PlutusBinary
forall (l :: Language). Plutus l -> PlutusBinary
Plutus.plutusBinary Plutus l
plutus)
          serialised :: C.PlutusScript (C.FromLedgerPlutusLanguage l)
          serialised :: PlutusScript (FromLedgerPlutusLanguage l)
serialised = ShortByteString -> PlutusScript (FromLedgerPlutusLanguage l)
forall lang. ShortByteString -> PlutusScript lang
C.PlutusScriptSerialised ShortByteString
binaryBytes
          asScript
            :: (lang ~ C.FromLedgerPlutusLanguage l, IsPlutusScriptInEra lang)
            => C.PlutusScriptVersion lang -> Maybe SomePlutusScript
          asScript :: forall lang.
(lang ~ FromLedgerPlutusLanguage l, IsPlutusScriptInEra lang) =>
PlutusScriptVersion lang -> Maybe SomePlutusScript
asScript PlutusScriptVersion lang
ver =
            if Script lang -> ScriptHash
forall lang. Script lang -> ScriptHash
C.hashScript (PlutusScriptVersion lang -> PlutusScript lang -> Script lang
forall lang.
IsPlutusScriptLanguage lang =>
PlutusScriptVersion lang -> PlutusScript lang -> Script lang
C.PlutusScript PlutusScriptVersion lang
ver PlutusScript lang
PlutusScript (FromLedgerPlutusLanguage l)
serialised) ScriptHash -> ScriptHash -> Bool
forall a. Eq a => a -> a -> Bool
== ScriptHash
targetHash
              then SomePlutusScript -> Maybe SomePlutusScript
forall a. a -> Maybe a
Just (PlutusScript lang -> SomePlutusScript
forall lang.
IsPlutusScriptInEra lang =>
PlutusScript lang -> SomePlutusScript
SomePlutusScript PlutusScript lang
PlutusScript (FromLedgerPlutusLanguage l)
serialised)
              else Maybe SomePlutusScript
forall a. Maybe a
Nothing
       in case forall (l :: Language). PlutusLanguage l => SLanguage l
Plutus.isLanguage @l of
            SLanguage l
Plutus.SPlutusV1 -> PlutusScriptVersion PlutusScriptV1 -> Maybe SomePlutusScript
forall lang.
(lang ~ FromLedgerPlutusLanguage l, IsPlutusScriptInEra lang) =>
PlutusScriptVersion lang -> Maybe SomePlutusScript
asScript PlutusScriptVersion PlutusScriptV1
C.PlutusScriptV1
            SLanguage l
Plutus.SPlutusV2 -> PlutusScriptVersion PlutusScriptV2 -> Maybe SomePlutusScript
forall lang.
(lang ~ FromLedgerPlutusLanguage l, IsPlutusScriptInEra lang) =>
PlutusScriptVersion lang -> Maybe SomePlutusScript
asScript PlutusScriptVersion PlutusScriptV2
C.PlutusScriptV2
            SLanguage l
Plutus.SPlutusV3 -> PlutusScriptVersion PlutusScriptV3 -> Maybe SomePlutusScript
forall lang.
(lang ~ FromLedgerPlutusLanguage l, IsPlutusScriptInEra lang) =>
PlutusScriptVersion lang -> Maybe SomePlutusScript
asScript PlutusScriptVersion PlutusScriptV3
C.PlutusScriptV3
            -- PlutusV4 is only available in Dijkstra
            SLanguage l
Plutus.SPlutusV4 -> Maybe SomePlutusScript
forall a. Maybe a
Nothing
  tryConvertScript ScriptHash
_ (Ledger.NativeScript NativeScript (ShelleyLedgerEra Era)
_) = Maybe SomePlutusScript
forall a. Maybe a
Nothing