-- | This module provides an automated attack to mint and give extra tokens to a
-- certain wallet.
module Cooked.Attack.AddToken (addTokenAttack, AddTokenLbl (..)) where

import Control.Monad
import Cooked.Skeleton
import Cooked.Tweak
import Cooked.Wallet
import Data.Map qualified as Map
import Plutus.Script.Utils.Scripts qualified as Script
import Plutus.Script.Utils.Value qualified as Script
import PlutusLedgerApi.V3 qualified as Api
import PlutusTx.Numeric qualified as PlutusTx

-- | This attack adds extra tokens, depending on the minting policy. It is
-- different from the 'dupTokenAttack' in that it does not merely try to
-- increase the amount of tokens minted: It tries to mint tokens of asset
-- classes that were not necessarily present on the unmodified transaction.
--
-- This attack adds an 'AddTokenLbl' with the token name of the additional
-- minted token(s). It returns additional value minted.
addTokenAttack ::
  (MonadTweak m) =>
  -- | For each policy that occurs in some 'Mints' constraint, return a list of
  -- token names together with how many tokens with that name should be minted.
  --
  -- For each of the elements of the returned list, one modified transaction
  -- with the additional tokens will be generated. (This means for example that,
  -- if there were three minting policies on the original transaction, and the
  -- lists returned for each of them have n,m, and o elements, respectively,
  -- there'll be n*m*o modified transactions.)
  --
  -- The redeemer will be unchanged
  (Script.Versioned Script.MintingPolicy -> [(Script.TokenName, Integer)]) ->
  -- | The wallet of the attacker where extra tokens will be paid to
  Wallet ->
  m Api.Value
addTokenAttack :: forall (m :: * -> *).
MonadTweak m =>
(Versioned MintingPolicy -> [(TokenName, Integer)])
-> Wallet -> m Value
addTokenAttack Versioned MintingPolicy -> [(TokenName, Integer)]
extraTokens Wallet
attacker = do
  TxSkelMints
oldMints <- Optic' A_Lens NoIx TxSkel TxSkelMints -> m TxSkelMints
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Getter) =>
Optic' k is TxSkel a -> m a
viewTweak Optic' A_Lens NoIx TxSkel TxSkelMints
txSkelMintsL
  [m Value] -> m Value
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([m Value] -> m Value) -> [m Value] -> m Value
forall a b. (a -> b) -> a -> b
$
    ((Versioned MintingPolicy,
  (TxSkelRedeemer, NEMap TokenName (NonZero Integer)))
 -> m Value)
-> [(Versioned MintingPolicy,
     (TxSkelRedeemer, NEMap TokenName (NonZero Integer)))]
-> [m Value]
forall a b. (a -> b) -> [a] -> [b]
map
      ( \(Versioned MintingPolicy
policy, (TxSkelRedeemer
redeemer, NEMap TokenName (NonZero Integer)
_)) ->
          [m Value] -> m Value
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([m Value] -> m Value) -> [m Value] -> m Value
forall a b. (a -> b) -> a -> b
$
            ((TokenName, Integer) -> m Value)
-> [(TokenName, Integer)] -> [m Value]
forall a b. (a -> b) -> [a] -> [b]
map
              ( \(TokenName
tName, Integer
amount) ->
                  let newMints :: TxSkelMints
newMints = (Versioned MintingPolicy, TxSkelRedeemer, TokenName, Integer)
-> TxSkelMints -> TxSkelMints
addToTxSkelMints (Versioned MintingPolicy
policy, TxSkelRedeemer
redeemer, TokenName
tName, Integer
amount) TxSkelMints
oldMints
                      increment :: Value
increment = TxSkelMints -> Value
txSkelMintsValue TxSkelMints
newMints Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
forall a. AdditiveGroup a => a -> a
PlutusTx.negate (TxSkelMints -> Value
txSkelMintsValue TxSkelMints
oldMints)
                   in if Value
increment Value -> Value -> Bool
`Script.geq` Value
forall a. Monoid a => a
mempty
                        then do
                          Optic' A_Lens NoIx TxSkel TxSkelMints -> TxSkelMints -> m ()
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Setter) =>
Optic' k is TxSkel a -> a -> m ()
setTweak Optic' A_Lens NoIx TxSkel TxSkelMints
txSkelMintsL TxSkelMints
newMints
                          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
increment
                          Value -> m Value
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
increment
                        else m Value
forall (m :: * -> *) a. MonadTweak m => m a
failingTweak
              )
              (Versioned MintingPolicy -> [(TokenName, Integer)]
extraTokens Versioned MintingPolicy
policy)
      )
      (TxSkelMints
-> [(Versioned MintingPolicy,
     (TxSkelRedeemer, NEMap TokenName (NonZero Integer)))]
forall k a. Map k a -> [(k, a)]
Map.toList TxSkelMints
oldMints)

newtype AddTokenLbl = AddTokenLbl Script.TokenName deriving (Int -> AddTokenLbl -> ShowS
[AddTokenLbl] -> ShowS
AddTokenLbl -> String
(Int -> AddTokenLbl -> ShowS)
-> (AddTokenLbl -> String)
-> ([AddTokenLbl] -> ShowS)
-> Show AddTokenLbl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AddTokenLbl -> ShowS
showsPrec :: Int -> AddTokenLbl -> ShowS
$cshow :: AddTokenLbl -> String
show :: AddTokenLbl -> String
$cshowList :: [AddTokenLbl] -> ShowS
showList :: [AddTokenLbl] -> ShowS
Show, AddTokenLbl -> AddTokenLbl -> Bool
(AddTokenLbl -> AddTokenLbl -> Bool)
-> (AddTokenLbl -> AddTokenLbl -> Bool) -> Eq AddTokenLbl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AddTokenLbl -> AddTokenLbl -> Bool
== :: AddTokenLbl -> AddTokenLbl -> Bool
$c/= :: AddTokenLbl -> AddTokenLbl -> Bool
/= :: AddTokenLbl -> AddTokenLbl -> Bool
Eq)