-- | This module provides an automated attack to duplicate tokens minted in a
-- transaction.
module Cooked.Attack.DupToken (dupTokenAttack, DupTokenLbl (..)) where

import Control.Monad
import Cooked.Pretty
import Cooked.Skeleton
import Cooked.Tweak
import Cooked.Wallet
import Optics.Core
import Plutus.Script.Utils.Typed qualified as Script
import Plutus.Script.Utils.V3.Scripts qualified as Script
import Plutus.Script.Utils.Value qualified as Script
import PlutusLedgerApi.V3 qualified as Api
import PlutusTx.Numeric qualified as PlutusTx

-- | A token duplication attack increases values in 'Mints'-constraints of a
-- 'TxSkel' according to some conditions, and pays the extra minted value to a
-- given recipient wallet. This adds a 'DupTokenLbl' to the labels of the
-- transaction using 'addLabel'. Returns the 'Value' by which the minted value
-- was increased.
dupTokenAttack ::
  (MonadTweak m) =>
  -- | A function describing how the amount of tokens specified by a 'Mints'
  -- constraint should be changed, depending on the asset class and the amount
  -- specified by the constraint. The given function @f@ should probably satisfy
  -- @f ac i > i@ for all @ac@ and @i@, i.e. it should increase the minted
  -- amount. If it does *not* increase the minted amount, the amount will be
  -- left unchanged.
  (Script.AssetClass -> Integer -> Integer) ->
  -- | The wallet of the attacker. Any additional tokens that are minted by the
  -- modified transaction but were not minted by the original transaction are
  -- paid to this wallet.
  Wallet ->
  m Api.Value
dupTokenAttack :: forall (m :: * -> *).
MonadTweak m =>
(AssetClass -> Integer -> Integer) -> Wallet -> m Value
dupTokenAttack AssetClass -> Integer -> Integer
change Wallet
attacker = do
  Value
totalIncrement <- m Value
forall (m :: * -> *). MonadTweak m => m Value
changeMintAmountsTweak
  TxSkelOut -> m ()
forall (m :: * -> *). MonadTweak m => TxSkelOut -> m ()
addOutputTweak (TxSkelOut -> m ()) -> TxSkelOut -> m ()
forall a b. (a -> b) -> a -> b
$ Wallet
attacker Wallet -> Payable '["Value"] -> TxSkelOut
forall owner (els :: [Symbol]).
(Show owner, Typeable owner, IsTxSkelOutAllowedOwner owner,
 ToCredential owner) =>
owner -> Payable els -> TxSkelOut
`receives` Value -> Payable '["Value"]
forall a1. ToValue a1 => a1 -> Payable '["Value"]
Value Value
totalIncrement
  DupTokenLbl -> m ()
forall (m :: * -> *) x. (MonadTweak m, LabelConstrs x) => x -> m ()
addLabelTweak DupTokenLbl
DupTokenLbl
  Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
totalIncrement
  where
    changeMintAmountsTweak :: (MonadTweak m) => m Api.Value
    changeMintAmountsTweak :: forall (m :: * -> *). MonadTweak m => m Value
changeMintAmountsTweak = do
      [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
oldMintsList <- Optic'
  A_Getter
  NoIx
  TxSkel
  [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
-> m [(Versioned MintingPolicy, TxSkelRedeemer, TokenName,
       Integer)]
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Getter) =>
Optic' k is TxSkel a -> m a
viewTweak (Optic'
   A_Getter
   NoIx
   TxSkel
   [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
 -> m [(Versioned MintingPolicy, TxSkelRedeemer, TokenName,
        Integer)])
-> Optic'
     A_Getter
     NoIx
     TxSkel
     [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
-> m [(Versioned MintingPolicy, TxSkelRedeemer, TokenName,
       Integer)]
forall a b. (a -> b) -> a -> b
$ Lens' TxSkel TxSkelMints
txSkelMintsL Lens' TxSkel TxSkelMints
-> Optic
     A_Getter
     NoIx
     TxSkelMints
     TxSkelMints
     [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
     [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
-> Optic'
     A_Getter
     NoIx
     TxSkel
     [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (TxSkelMints
 -> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)])
-> Optic
     A_Getter
     NoIx
     TxSkelMints
     TxSkelMints
     [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
     [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
forall s a. (s -> a) -> Getter s a
to TxSkelMints
-> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
txSkelMintsToList
      let newMintsList :: [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
newMintsList =
            ((Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)
 -> (Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer))
-> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
-> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
forall a b. (a -> b) -> [a] -> [b]
map
              ( \(Script.Versioned MintingPolicy
policy Language
version, TxSkelRedeemer
redeemer, TokenName
tName, Integer
oldAmount) ->
                  let ac :: AssetClass
ac = CurrencySymbol -> TokenName -> AssetClass
Script.assetClass (MintingPolicyHash -> CurrencySymbol
Script.mpsSymbol (MintingPolicyHash -> CurrencySymbol)
-> MintingPolicyHash -> CurrencySymbol
forall a b. (a -> b) -> a -> b
$ MintingPolicy -> MintingPolicyHash
Script.mintingPolicyHash MintingPolicy
policy) TokenName
tName
                      newAmount :: Integer
newAmount = AssetClass -> Integer -> Integer
change AssetClass
ac Integer
oldAmount
                   in (MintingPolicy -> Language -> Versioned MintingPolicy
forall script. script -> Language -> Versioned script
Script.Versioned MintingPolicy
policy Language
version, TxSkelRedeemer
redeemer, TokenName
tName, Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
max Integer
newAmount Integer
oldAmount)
              )
              [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
oldMintsList
      Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
newMintsList [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
-> [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
-> Bool
forall a. Eq a => a -> a -> Bool
/= [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
oldMintsList
      let newMints :: TxSkelMints
newMints = [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
-> TxSkelMints
txSkelMintsFromList [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
newMintsList
          newValue :: Value
newValue = TxSkelMints -> Value
txSkelMintsValue TxSkelMints
newMints
          oldValue :: Value
oldValue = TxSkelMints -> Value
txSkelMintsValue (TxSkelMints -> Value) -> TxSkelMints -> Value
forall a b. (a -> b) -> a -> b
$ [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
-> TxSkelMints
txSkelMintsFromList [(Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)]
oldMintsList
      Lens' TxSkel TxSkelMints -> TxSkelMints -> m ()
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Setter) =>
Optic' k is TxSkel a -> a -> m ()
setTweak Lens' TxSkel TxSkelMints
txSkelMintsL TxSkelMints
newMints
      Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> m Value) -> Value -> m Value
forall a b. (a -> b) -> a -> b
$ Value
newValue Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
forall a. AdditiveGroup a => a -> a
PlutusTx.negate Value
oldValue

data DupTokenLbl = DupTokenLbl
  deriving (DupTokenLbl -> DupTokenLbl -> Bool
(DupTokenLbl -> DupTokenLbl -> Bool)
-> (DupTokenLbl -> DupTokenLbl -> Bool) -> Eq DupTokenLbl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DupTokenLbl -> DupTokenLbl -> Bool
== :: DupTokenLbl -> DupTokenLbl -> Bool
$c/= :: DupTokenLbl -> DupTokenLbl -> Bool
/= :: DupTokenLbl -> DupTokenLbl -> Bool
Eq, Int -> DupTokenLbl -> ShowS
[DupTokenLbl] -> ShowS
DupTokenLbl -> String
(Int -> DupTokenLbl -> ShowS)
-> (DupTokenLbl -> String)
-> ([DupTokenLbl] -> ShowS)
-> Show DupTokenLbl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DupTokenLbl -> ShowS
showsPrec :: Int -> DupTokenLbl -> ShowS
$cshow :: DupTokenLbl -> String
show :: DupTokenLbl -> String
$cshowList :: [DupTokenLbl] -> ShowS
showList :: [DupTokenLbl] -> ShowS
Show, Eq DupTokenLbl
Eq DupTokenLbl =>
(DupTokenLbl -> DupTokenLbl -> Ordering)
-> (DupTokenLbl -> DupTokenLbl -> Bool)
-> (DupTokenLbl -> DupTokenLbl -> Bool)
-> (DupTokenLbl -> DupTokenLbl -> Bool)
-> (DupTokenLbl -> DupTokenLbl -> Bool)
-> (DupTokenLbl -> DupTokenLbl -> DupTokenLbl)
-> (DupTokenLbl -> DupTokenLbl -> DupTokenLbl)
-> Ord DupTokenLbl
DupTokenLbl -> DupTokenLbl -> Bool
DupTokenLbl -> DupTokenLbl -> Ordering
DupTokenLbl -> DupTokenLbl -> DupTokenLbl
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: DupTokenLbl -> DupTokenLbl -> Ordering
compare :: DupTokenLbl -> DupTokenLbl -> Ordering
$c< :: DupTokenLbl -> DupTokenLbl -> Bool
< :: DupTokenLbl -> DupTokenLbl -> Bool
$c<= :: DupTokenLbl -> DupTokenLbl -> Bool
<= :: DupTokenLbl -> DupTokenLbl -> Bool
$c> :: DupTokenLbl -> DupTokenLbl -> Bool
> :: DupTokenLbl -> DupTokenLbl -> Bool
$c>= :: DupTokenLbl -> DupTokenLbl -> Bool
>= :: DupTokenLbl -> DupTokenLbl -> Bool
$cmax :: DupTokenLbl -> DupTokenLbl -> DupTokenLbl
max :: DupTokenLbl -> DupTokenLbl -> DupTokenLbl
$cmin :: DupTokenLbl -> DupTokenLbl -> DupTokenLbl
min :: DupTokenLbl -> DupTokenLbl -> DupTokenLbl
Ord)

instance PrettyCooked DupTokenLbl where
  prettyCooked :: DupTokenLbl -> DocCooked
prettyCooked DupTokenLbl
_ = DocCooked
"DupToken"