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
dupTokenAttack ::
(MonadTweak m, OwnerConstraints o) =>
(Api.AssetClass -> Integer -> Integer) ->
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
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"