-- | This module provides two automated attacks to mint and give extra tokens to
-- a certain target.
module Cooked.Attack.AddToken
  ( addTokenAttack,
    AddTokenLbl (..),
    dupTokenAttack,
    DupTokenLbl (..),
  )
where

import Control.Monad
import Cooked.Pretty.Class
import Cooked.Skeleton
import Cooked.Tweak.Common
import Cooked.Tweak.Labels
import Cooked.Tweak.Outputs
import Data.Map qualified as Map
import Optics.Core
import Plutus.Script.Utils.Value qualified as Script
import PlutusLedgerApi.V3 qualified as Api
import PlutusTx.Numeric qualified as PlutusTx
import Polysemy
import Polysemy.NonDet
import Prettyprinter qualified as PP

-- | This attack adds extra tokens of any kind for minting policies already
-- present in the minted value. The additional minted value is redirected to a
-- certain owner in a dedicated output.
--
-- This attack adds an 'AddTokenLbl' label.
addTokenAttack ::
  ( Members '[Tweak, NonDet] effs,
    IsTxSkelOutAllowedOwner 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.
  (VScript -> [(Api.TokenName, Integer)]) ->
  -- | The attacker, who receives the extra tokens.
  o ->
  Sem effs Api.Value
addTokenAttack :: forall (effs :: EffectRow) o.
(Members '[Tweak, NonDet] effs, IsTxSkelOutAllowedOwner o) =>
(VScript -> [(TokenName, Integer)]) -> o -> Sem effs Value
addTokenAttack VScript -> [(TokenName, Integer)]
extraTokens o
attacker = do
  [VScript]
currencies <- Optic' A_Getter '[] TxSkel [VScript] -> Sem effs [VScript]
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Getter) =>
Optic' k is TxSkel a -> Sem effs a
viewTweak (Lens' TxSkel TxSkelMints
txSkelMintsL Lens' TxSkel TxSkelMints
-> Optic
     A_Getter
     '[]
     TxSkelMints
     TxSkelMints
     [(VScript, TokenName)]
     [(VScript, TokenName)]
-> Optic
     A_Getter
     '[]
     TxSkel
     TxSkel
     [(VScript, TokenName)]
     [(VScript, TokenName)]
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
% Optic
  A_Getter
  '[]
  TxSkelMints
  TxSkelMints
  [(VScript, TokenName)]
  [(VScript, TokenName)]
txSkelMintsAssetClassesG Optic
  A_Getter
  '[]
  TxSkel
  TxSkel
  [(VScript, TokenName)]
  [(VScript, TokenName)]
-> Optic
     A_Getter
     '[]
     [(VScript, TokenName)]
     [(VScript, TokenName)]
     [VScript]
     [VScript]
-> Optic' A_Getter '[] TxSkel [VScript]
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
% ([(VScript, TokenName)] -> [VScript])
-> Optic
     A_Getter
     '[]
     [(VScript, TokenName)]
     [(VScript, TokenName)]
     [VScript]
     [VScript]
forall s a. (s -> a) -> Getter s a
to (((VScript, TokenName) -> VScript)
-> [(VScript, TokenName)] -> [VScript]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (VScript, TokenName) -> VScript
forall a b. (a, b) -> a
fst))
  Value
oldMintsValue <- Optic' A_Getter '[] TxSkel Value -> Sem effs Value
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Getter) =>
Optic' k is TxSkel a -> Sem effs a
viewTweak (Lens' TxSkel TxSkelMints
txSkelMintsL Lens' TxSkel TxSkelMints
-> Optic A_Getter '[] TxSkelMints TxSkelMints Value Value
-> Optic' A_Getter '[] TxSkel Value
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 -> Value)
-> Optic A_Getter '[] TxSkelMints TxSkelMints Value Value
forall s a. (s -> a) -> Getter s a
to TxSkelMints -> Value
forall a. ToValue a => a -> Value
Script.toValue)
  [(VScript, TokenName, Integer)]
-> ((VScript, TokenName, Integer) -> Sem effs ()) -> Sem effs ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(VScript
mp, TokenName
tk, Integer
n) | VScript
mp <- [VScript]
currencies, (TokenName
tk, Integer
n) <- VScript -> [(TokenName, Integer)]
extraTokens VScript
mp] (((VScript, TokenName, Integer) -> Sem effs ()) -> Sem effs ())
-> ((VScript, TokenName, Integer) -> Sem effs ()) -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ \(VScript
mp, TokenName
tk, Integer
n) ->
    Optic' A_Lens '[] TxSkel Integer
-> (Integer -> Integer) -> Sem effs ()
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Setter) =>
Optic' k is TxSkel a -> (a -> a) -> Sem effs ()
overTweak (Lens' TxSkel TxSkelMints
txSkelMintsL Lens' TxSkel TxSkelMints
-> Optic
     A_Lens
     '[]
     TxSkelMints
     TxSkelMints
     (Maybe TxSkelRedeemer, Integer)
     (Maybe TxSkelRedeemer, Integer)
-> Optic
     A_Lens
     '[]
     TxSkel
     TxSkel
     (Maybe TxSkelRedeemer, Integer)
     (Maybe TxSkelRedeemer, 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
% VScript
-> TokenName
-> Optic
     A_Lens
     '[]
     TxSkelMints
     TxSkelMints
     (Maybe TxSkelRedeemer, Integer)
     (Maybe TxSkelRedeemer, Integer)
forall mp.
(ToVScript mp, Typeable mp) =>
mp
-> TokenName
-> Optic
     A_Lens
     '[]
     TxSkelMints
     TxSkelMints
     (Maybe TxSkelRedeemer, Integer)
     (Maybe TxSkelRedeemer, Integer)
txSkelMintsAssetClassAmountL VScript
mp TokenName
tk Optic
  A_Lens
  '[]
  TxSkel
  TxSkel
  (Maybe TxSkelRedeemer, Integer)
  (Maybe TxSkelRedeemer, Integer)
-> Optic
     A_Lens
     '[]
     (Maybe TxSkelRedeemer, Integer)
     (Maybe TxSkelRedeemer, Integer)
     Integer
     Integer
-> Optic' A_Lens '[] TxSkel 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
% Optic
  A_Lens
  '[]
  (Maybe TxSkelRedeemer, Integer)
  (Maybe TxSkelRedeemer, Integer)
  Integer
  Integer
forall s t a b. Field2 s t a b => Lens s t a b
_2) (Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n)
  Value
totalIncrement <- Optic' A_Getter '[] TxSkel Value -> Sem effs Value
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Getter) =>
Optic' k is TxSkel a -> Sem effs a
viewTweak (Lens' TxSkel TxSkelMints
txSkelMintsL Lens' TxSkel TxSkelMints
-> Optic A_Getter '[] TxSkelMints TxSkelMints Value Value
-> Optic' A_Getter '[] TxSkel Value
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 -> Value)
-> Optic A_Getter '[] TxSkelMints TxSkelMints Value Value
forall s a. (s -> a) -> Getter s a
to TxSkelMints -> Value
forall a. ToValue a => a -> Value
Script.toValue Optic' A_Getter '[] TxSkel Value
-> Optic A_Getter '[] Value Value Value Value
-> Optic' A_Getter '[] TxSkel Value
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
% (Value -> Value) -> Optic A_Getter '[] Value Value Value Value
forall s a. (s -> a) -> Getter s a
to (Value -> Value -> Value
forall a. Semigroup a => a -> a -> a
<> Value -> Value
forall a. AdditiveGroup a => a -> a
PlutusTx.negate Value
oldMintsValue))
  Bool -> Sem effs ()
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)
  TxSkelOut -> Sem effs ()
forall (effs :: EffectRow).
Member Tweak effs =>
TxSkelOut -> Sem effs ()
addOutputTweak (TxSkelOut -> Sem effs ()) -> TxSkelOut -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ o
attacker o -> Payable '[ 'IsValue] -> TxSkelOut
forall owner (els :: [PayableKind]).
IsTxSkelOutAllowedOwner owner =>
owner -> Payable els -> TxSkelOut
`receives` Value -> Payable '[ 'IsValue]
forall a1. ToValue a1 => a1 -> Payable '[ 'IsValue]
Value Value
totalIncrement
  AddTokenLbl -> Sem effs ()
forall lbl (effs :: EffectRow).
(LabelConstrs lbl, Member Tweak effs) =>
lbl -> Sem effs ()
addLabelTweak AddTokenLbl
AddTokenLbl
  Value -> Sem effs Value
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
totalIncrement

-- | This attack is similar to 'addTokenAttack' with the exception that it only
-- tampers with token names already present.
--
-- This attack adds an 'DupTokenLbl' label
dupTokenAttack ::
  ( Members '[Tweak, NonDet] effs,
    IsTxSkelOutAllowedOwner 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, the tweak will still succeed but this might result
  -- in negative portions in the value paid to the attacker.
  (VScript -> Api.TokenName -> Integer -> Integer) ->
  -- | The target of the extra tokens. Any additional tokens that are minted by
  -- the modified transaction but were not minted by the original transaction
  -- are paid to this target.
  o ->
  Sem effs Api.Value
dupTokenAttack :: forall (effs :: EffectRow) o.
(Members '[Tweak, NonDet] effs, IsTxSkelOutAllowedOwner o) =>
(VScript -> TokenName -> Integer -> Integer) -> o -> Sem effs Value
dupTokenAttack VScript -> TokenName -> Integer -> Integer
change o
attacker = do
  TxSkelMints
mints <- Lens' TxSkel TxSkelMints -> Sem effs TxSkelMints
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Getter) =>
Optic' k is TxSkel a -> Sem effs a
viewTweak Lens' TxSkel TxSkelMints
txSkelMintsL
  Value
res <-
    (VScript -> [(TokenName, Integer)]) -> o -> Sem effs Value
forall (effs :: EffectRow) o.
(Members '[Tweak, NonDet] effs, IsTxSkelOutAllowedOwner o) =>
(VScript -> [(TokenName, Integer)]) -> o -> Sem effs Value
addTokenAttack
      ( \VScript
s ->
          [(TokenName, Integer)]
-> ((TxSkelRedeemer, Map TokenName Integer)
    -> [(TokenName, Integer)])
-> Maybe (TxSkelRedeemer, Map TokenName Integer)
-> [(TokenName, Integer)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            []
            (\(TxSkelRedeemer
_, Map TokenName Integer
subMap) -> [(TokenName
tk, VScript -> TokenName -> Integer -> Integer
change VScript
s TokenName
tk Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
n) | (TokenName
tk, Integer
n) <- Map TokenName Integer -> [(TokenName, Integer)]
forall k a. Map k a -> [(k, a)]
Map.toList Map TokenName Integer
subMap])
            (Optic'
  A_Lens
  '[]
  TxSkelMints
  (Maybe (TxSkelRedeemer, Map TokenName Integer))
-> TxSkelMints -> Maybe (TxSkelRedeemer, Map TokenName Integer)
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (VScript
-> Optic'
     A_Lens
     '[]
     TxSkelMints
     (Maybe (TxSkelRedeemer, Map TokenName Integer))
forall mp.
(ToVScript mp, Typeable mp) =>
mp
-> Optic'
     A_Lens
     '[]
     TxSkelMints
     (Maybe (TxSkelRedeemer, Map TokenName Integer))
txSkelMintsPolicyTokensL VScript
s) TxSkelMints
mints)
      )
      o
attacker
  AddTokenLbl -> Sem effs ()
forall lbl (effs :: EffectRow).
(LabelConstrs lbl, Members '[Tweak, NonDet] effs) =>
lbl -> Sem effs ()
removeLabelTweak AddTokenLbl
AddTokenLbl
  DupTokenLbl -> Sem effs ()
forall lbl (effs :: EffectRow).
(LabelConstrs lbl, Member Tweak effs) =>
lbl -> Sem effs ()
addLabelTweak DupTokenLbl
DupTokenLbl
  Value -> Sem effs Value
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
res

-- | 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

-- | 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"