-- | 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.Pretty
import Cooked.Skeleton
import Cooked.Tweak
import Optics.Core
import Plutus.Script.Utils.Scripts qualified as Script
import PlutusLedgerApi.V3 qualified as Api
import PlutusTx.AssocMap qualified as PMap
import Prettyprinter qualified as PP

-- | This attack adds extra tokens, depending on the minting policy. It is
-- different from the 'Cooked.Attack.DupToken.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' label.
addTokenAttack ::
  (MonadTweak m, OwnerConstraints o) =>
  -- | For each policy that occurs in some 'Mint' constraint, return a list of
  -- token names together with how many tokens with that name should be minted.
  (Script.Versioned Script.MintingPolicy -> [(Api.TokenName, Integer)]) ->
  -- | The wallet of the attacker where extra tokens will be paid to
  o ->
  m Api.Value
addTokenAttack :: forall (m :: * -> *) o.
(MonadTweak m, OwnerConstraints o) =>
(Versioned MintingPolicy -> [(TokenName, Integer)]) -> o -> m Value
addTokenAttack Versioned MintingPolicy -> [(TokenName, Integer)]
extraTokens 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@(forall s a. ToVersioned s a => a -> Versioned s
Script.toVersioned @Script.MintingPolicy -> Versioned MintingPolicy
mp') TxSkelRedeemer
red [(TokenName, Integer)]
tks) ->
              let change :: [(TokenName, Integer)]
change = Versioned MintingPolicy -> [(TokenName, Integer)]
extraTokens Versioned MintingPolicy
mp'
               in ( a -> TxSkelRedeemer -> [(TokenName, Integer)] -> Mint
forall a.
ToVersioned MintingPolicy a =>
a -> TxSkelRedeemer -> [(TokenName, Integer)] -> Mint
Mint a
mp TxSkelRedeemer
red ([(TokenName, Integer)]
tks [(TokenName, Integer)]
-> [(TokenName, Integer)] -> [(TokenName, Integer)]
forall a. [a] -> [a] -> [a]
++ [(TokenName, Integer)]
change) Mint -> [Mint] -> [Mint]
forall a. a -> [a] -> [a]
: [Mint]
newMs,
                    Map CurrencySymbol (Map TokenName Integer) -> Value
Api.Value (CurrencySymbol
-> Map TokenName Integer
-> Map CurrencySymbol (Map TokenName Integer)
forall k v. k -> v -> Map k v
PMap.singleton (Versioned MintingPolicy -> CurrencySymbol
forall script.
ToMintingPolicyHash script =>
script -> CurrencySymbol
Script.toCurrencySymbol Versioned MintingPolicy
mp') ([(TokenName, Integer)] -> Map TokenName Integer
forall k v. [(k, v)] -> Map k v
PMap.unsafeFromList [(TokenName, Integer)]
change)) 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
  AddTokenLbl -> m ()
forall (m :: * -> *) x. (MonadTweak m, LabelConstrs x) => x -> m ()
addLabelTweak AddTokenLbl
AddTokenLbl
  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
-- 'addTokenAttack'
data AddTokenLbl = AddTokenLbl 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, Eq AddTokenLbl
Eq AddTokenLbl =>
(AddTokenLbl -> AddTokenLbl -> Ordering)
-> (AddTokenLbl -> AddTokenLbl -> Bool)
-> (AddTokenLbl -> AddTokenLbl -> Bool)
-> (AddTokenLbl -> AddTokenLbl -> Bool)
-> (AddTokenLbl -> AddTokenLbl -> Bool)
-> (AddTokenLbl -> AddTokenLbl -> AddTokenLbl)
-> (AddTokenLbl -> AddTokenLbl -> AddTokenLbl)
-> Ord AddTokenLbl
AddTokenLbl -> AddTokenLbl -> Bool
AddTokenLbl -> AddTokenLbl -> Ordering
AddTokenLbl -> AddTokenLbl -> AddTokenLbl
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 :: AddTokenLbl -> AddTokenLbl -> Ordering
compare :: AddTokenLbl -> AddTokenLbl -> Ordering
$c< :: AddTokenLbl -> AddTokenLbl -> Bool
< :: AddTokenLbl -> AddTokenLbl -> Bool
$c<= :: AddTokenLbl -> AddTokenLbl -> Bool
<= :: AddTokenLbl -> AddTokenLbl -> Bool
$c> :: AddTokenLbl -> AddTokenLbl -> Bool
> :: AddTokenLbl -> AddTokenLbl -> Bool
$c>= :: AddTokenLbl -> AddTokenLbl -> Bool
>= :: AddTokenLbl -> AddTokenLbl -> Bool
$cmax :: AddTokenLbl -> AddTokenLbl -> AddTokenLbl
max :: AddTokenLbl -> AddTokenLbl -> AddTokenLbl
$cmin :: AddTokenLbl -> AddTokenLbl -> AddTokenLbl
min :: AddTokenLbl -> AddTokenLbl -> AddTokenLbl
Ord)

instance PrettyCooked AddTokenLbl where
  prettyCooked :: AddTokenLbl -> DocCooked
prettyCooked = AddTokenLbl -> DocCooked
forall a ann. Show a => a -> Doc ann
PP.viaShow