-- | 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 Optics.Core
import Plutus.Script.Utils.Scripts qualified as Script
import PlutusLedgerApi.V1.Value qualified as Api

-- | A token duplication attack increases values in 'Mint' 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 'addLabelTweak'. Returns the 'Value' by which the minted
-- value was increased.
dupTokenAttack ::
  (MonadTweak m, OwnerConstraints o) =>
  -- | A function describing how the amount of tokens specified by a 'Mint'
  -- 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.
  (Api.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.
  o ->
  m Api.Value
dupTokenAttack :: forall (m :: * -> *) o.
(MonadTweak m, OwnerConstraints o) =>
(AssetClass -> Integer -> Integer) -> o -> m Value
dupTokenAttack AssetClass -> Integer -> Integer
change o
attacker = do
  [Mint]
oldMintsList <- Optic' A_Getter NoIx TxSkel [Mint] -> m [Mint]
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 [Mint] -> m [Mint])
-> Optic' A_Getter NoIx TxSkel [Mint] -> m [Mint]
forall a b. (a -> b) -> a -> b
$ Lens' TxSkel TxSkelMints
txSkelMintsL Lens' TxSkel TxSkelMints
-> Optic A_Getter NoIx TxSkelMints TxSkelMints [Mint] [Mint]
-> Optic' A_Getter NoIx TxSkel [Mint]
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 -> [Mint])
-> Optic A_Getter NoIx TxSkelMints TxSkelMints [Mint] [Mint]
forall s a. (s -> a) -> Getter s a
to TxSkelMints -> [Mint]
txSkelMintsToList
  let ([Mint]
newMintsList, Value
totalIncrement) =
        (([Mint], Value) -> Mint -> ([Mint], Value))
-> ([Mint], Value) -> [Mint] -> ([Mint], Value)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
          ( \([Mint]
newMs, Value
addVal) (Mint mp :: a
mp@(Versioned MintingPolicy -> CurrencySymbol
forall script.
ToMintingPolicyHash script =>
script -> CurrencySymbol
Script.toCurrencySymbol (Versioned MintingPolicy -> CurrencySymbol)
-> (a -> Versioned MintingPolicy) -> a -> CurrencySymbol
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. ToVersioned s a => a -> Versioned s
Script.toVersioned @Script.MintingPolicy -> CurrencySymbol
cs) TxSkelRedeemer
red [(TokenName, Integer)]
tks) ->
              let ([(TokenName, Integer)]
newTokensList, Value
addValTokens) =
                    (([(TokenName, Integer)], Value)
 -> (TokenName, Integer) -> ([(TokenName, Integer)], Value))
-> ([(TokenName, Integer)], Value)
-> [(TokenName, Integer)]
-> ([(TokenName, Integer)], Value)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
                      ( \([(TokenName, Integer)]
newTks, Value
addVal') (TokenName
tn, Integer
n) ->
                          let newAmount :: Integer
newAmount = AssetClass -> Integer -> Integer
change (CurrencySymbol -> TokenName -> AssetClass
Api.assetClass CurrencySymbol
cs TokenName
tn) Integer
n
                           in if Integer
newAmount Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
n
                                then ((TokenName
tn, Integer
newAmount) (TokenName, Integer)
-> [(TokenName, Integer)] -> [(TokenName, Integer)]
forall a. a -> [a] -> [a]
: [(TokenName, Integer)]
newTks, Value
addVal' Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> CurrencySymbol -> TokenName -> Integer -> Value
Api.singleton CurrencySymbol
cs TokenName
tn (Integer
newAmount Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
n))
                                else ((TokenName
tn, Integer
n) (TokenName, Integer)
-> [(TokenName, Integer)] -> [(TokenName, Integer)]
forall a. a -> [a] -> [a]
: [(TokenName, Integer)]
newTks, Value
addVal')
                      )
                      ([], Value
forall a. Monoid a => a
mempty)
                      [(TokenName, Integer)]
tks
               in (a -> TxSkelRedeemer -> [(TokenName, Integer)] -> Mint
forall a.
ToVersioned MintingPolicy a =>
a -> TxSkelRedeemer -> [(TokenName, Integer)] -> Mint
Mint a
mp TxSkelRedeemer
red [(TokenName, Integer)]
newTokensList Mint -> [Mint] -> [Mint]
forall a. a -> [a] -> [a]
: [Mint]
newMs, Value
addValTokens Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value
addVal)
          )
          ([], Value
forall a. Monoid a => a
mempty)
          [Mint]
oldMintsList
  Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Value
totalIncrement Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
/= Value
forall a. Monoid a => a
mempty)
  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 -> m ()) -> TxSkelMints -> m ()
forall a b. (a -> b) -> a -> b
$ [Mint] -> TxSkelMints
txSkelMintsFromList [Mint]
newMintsList
  TxSkelOut -> m ()
forall (m :: * -> *). MonadTweak m => TxSkelOut -> m ()
addOutputTweak (TxSkelOut -> m ()) -> TxSkelOut -> m ()
forall a b. (a -> b) -> a -> b
$ o
attacker o -> 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

-- | A label that is added to a 'TxSkel' that has successfully been modified by
-- the 'dupTokenAttack'
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"