-- | This module provides an automated attack to add minted tokens in a
-- 'TxSkel'. In principle, a token duplication attack consist in minting a
-- higher amount of tokens already minted in the transaction, but we generalise
-- it to also add arbitrary tokens if needed.
module Cooked.Attack.TokenDuplication
  ( -- * Token duplication params
    TokenDuplicationParams (..),
    anyMintTokenDuplicationParams,
    existingCurrencyTokenDuplicationParams,
    existingAssetClassTokenDuplicationParams,

    -- * Token duplication label
    TokenDuplicationLabel (..),

    -- * Token duplication attack
    tokenDuplicationAttack,
  )
where

import Control.Monad
import Cooked.Pretty.Class
import Cooked.Skeleton
import Cooked.Tweak
import Optics.Core
import Plutus.Script.Utils.Value qualified as Script
import PlutusLedgerApi.V1.Value qualified as Api
import Polysemy
import Polysemy.NonDet

-- | A label added to a 'TxSkel' on which a tweak duplicating tokens has been
-- applied. The label contains the value that was added to the transaction.
newtype TokenDuplicationLabel = TokenDuplicationLabel Api.Value
  deriving (Int -> TokenDuplicationLabel -> ShowS
[TokenDuplicationLabel] -> ShowS
TokenDuplicationLabel -> String
(Int -> TokenDuplicationLabel -> ShowS)
-> (TokenDuplicationLabel -> String)
-> ([TokenDuplicationLabel] -> ShowS)
-> Show TokenDuplicationLabel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TokenDuplicationLabel -> ShowS
showsPrec :: Int -> TokenDuplicationLabel -> ShowS
$cshow :: TokenDuplicationLabel -> String
show :: TokenDuplicationLabel -> String
$cshowList :: [TokenDuplicationLabel] -> ShowS
showList :: [TokenDuplicationLabel] -> ShowS
Show, TokenDuplicationLabel -> TokenDuplicationLabel -> Bool
(TokenDuplicationLabel -> TokenDuplicationLabel -> Bool)
-> (TokenDuplicationLabel -> TokenDuplicationLabel -> Bool)
-> Eq TokenDuplicationLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TokenDuplicationLabel -> TokenDuplicationLabel -> Bool
== :: TokenDuplicationLabel -> TokenDuplicationLabel -> Bool
$c/= :: TokenDuplicationLabel -> TokenDuplicationLabel -> Bool
/= :: TokenDuplicationLabel -> TokenDuplicationLabel -> Bool
Eq, Eq TokenDuplicationLabel
Eq TokenDuplicationLabel =>
(TokenDuplicationLabel -> TokenDuplicationLabel -> Ordering)
-> (TokenDuplicationLabel -> TokenDuplicationLabel -> Bool)
-> (TokenDuplicationLabel -> TokenDuplicationLabel -> Bool)
-> (TokenDuplicationLabel -> TokenDuplicationLabel -> Bool)
-> (TokenDuplicationLabel -> TokenDuplicationLabel -> Bool)
-> (TokenDuplicationLabel
    -> TokenDuplicationLabel -> TokenDuplicationLabel)
-> (TokenDuplicationLabel
    -> TokenDuplicationLabel -> TokenDuplicationLabel)
-> Ord TokenDuplicationLabel
TokenDuplicationLabel -> TokenDuplicationLabel -> Bool
TokenDuplicationLabel -> TokenDuplicationLabel -> Ordering
TokenDuplicationLabel
-> TokenDuplicationLabel -> TokenDuplicationLabel
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 :: TokenDuplicationLabel -> TokenDuplicationLabel -> Ordering
compare :: TokenDuplicationLabel -> TokenDuplicationLabel -> Ordering
$c< :: TokenDuplicationLabel -> TokenDuplicationLabel -> Bool
< :: TokenDuplicationLabel -> TokenDuplicationLabel -> Bool
$c<= :: TokenDuplicationLabel -> TokenDuplicationLabel -> Bool
<= :: TokenDuplicationLabel -> TokenDuplicationLabel -> Bool
$c> :: TokenDuplicationLabel -> TokenDuplicationLabel -> Bool
> :: TokenDuplicationLabel -> TokenDuplicationLabel -> Bool
$c>= :: TokenDuplicationLabel -> TokenDuplicationLabel -> Bool
>= :: TokenDuplicationLabel -> TokenDuplicationLabel -> Bool
$cmax :: TokenDuplicationLabel
-> TokenDuplicationLabel -> TokenDuplicationLabel
max :: TokenDuplicationLabel
-> TokenDuplicationLabel -> TokenDuplicationLabel
$cmin :: TokenDuplicationLabel
-> TokenDuplicationLabel -> TokenDuplicationLabel
min :: TokenDuplicationLabel
-> TokenDuplicationLabel -> TokenDuplicationLabel
Ord)

instance PrettyCooked TokenDuplicationLabel where
  prettyCookedOpt :: PrettyCookedOpts -> TokenDuplicationLabel -> DocCooked
prettyCookedOpt PrettyCookedOpts
ops (TokenDuplicationLabel Value
val) =
    DocCooked
"Added value: " DocCooked -> DocCooked -> DocCooked
forall a. Semigroup a => a -> a -> a
<> PrettyCookedOpts -> Value -> DocCooked
forall a. PrettyCooked a => PrettyCookedOpts -> a -> DocCooked
prettyCookedOpt PrettyCookedOpts
ops Value
val

-- | Parameters of the token duplication attack
data TokenDuplicationParams owner effs
  = TokenDuplicationParams
  { -- | The new mints to add in the transaction. These are effectful because
    -- they can depend on the existing mints.
    forall owner (effs :: EffectRow).
TokenDuplicationParams owner effs -> Sem effs [Mint]
tdpNewMints :: Sem effs [Mint],
    -- | The target of the added tokens.
    forall owner (effs :: EffectRow).
TokenDuplicationParams owner effs -> owner
tdpThief :: owner
  }

-- | Token duplications based on a list of 'Mint'.
anyMintTokenDuplicationParams ::
  -- | The 'Mint's to add.
  [Mint] ->
  -- | The attacker, who receives the extra tokens.
  owner ->
  TokenDuplicationParams owner effs
anyMintTokenDuplicationParams :: forall owner (effs :: EffectRow).
[Mint] -> owner -> TokenDuplicationParams owner effs
anyMintTokenDuplicationParams [Mint]
mints =
  Sem effs [Mint] -> owner -> TokenDuplicationParams owner effs
forall owner (effs :: EffectRow).
Sem effs [Mint] -> owner -> TokenDuplicationParams owner effs
TokenDuplicationParams ([Mint] -> Sem effs [Mint]
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return [Mint]
mints)

-- | Token duplications based on a function applied to existing currencies (cannot add
-- new currencies, but can add new types of tokens).
existingCurrencyTokenDuplicationParams ::
  (Member Tweak effs) =>
  -- | 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,
  -- in addition to the existing tokens.
  (VScript -> [(Api.TokenName, Integer)]) ->
  -- | The attacker, who receives the extra tokens.
  owner ->
  TokenDuplicationParams owner effs
existingCurrencyTokenDuplicationParams :: forall (effs :: EffectRow) owner.
Member Tweak effs =>
(VScript -> [(TokenName, Integer)])
-> owner -> TokenDuplicationParams owner effs
existingCurrencyTokenDuplicationParams VScript -> [(TokenName, Integer)]
newTokens = Sem effs [Mint] -> owner -> TokenDuplicationParams owner effs
forall owner (effs :: EffectRow).
Sem effs [Mint] -> owner -> TokenDuplicationParams owner effs
TokenDuplicationParams (Sem effs [Mint] -> owner -> TokenDuplicationParams owner effs)
-> Sem effs [Mint] -> owner -> TokenDuplicationParams owner effs
forall a b. (a -> b) -> a -> b
$ do
  [User 'IsScript 'Redemption]
currencies <- Optic' A_Traversal '[] TxSkel (User 'IsScript 'Redemption)
-> Sem effs [User 'IsScript 'Redemption]
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Fold) =>
Optic' k is TxSkel a -> Sem effs [a]
toListOfTweak (Lens' TxSkel TxSkelMints
txSkelMintsL Lens' TxSkel TxSkelMints
-> Optic An_Iso '[] TxSkelMints TxSkelMints [Mint] [Mint]
-> Optic A_Lens '[] TxSkel TxSkel [Mint] [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
% Optic An_Iso '[] TxSkelMints TxSkelMints [Mint] [Mint]
txSkelMintsListI Optic A_Lens '[] TxSkel TxSkel [Mint] [Mint]
-> Optic A_Traversal '[] [Mint] [Mint] Mint Mint
-> Optic A_Traversal '[] TxSkel TxSkel Mint 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
% Optic A_Traversal '[] [Mint] [Mint] Mint Mint
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed Optic A_Traversal '[] TxSkel TxSkel Mint Mint
-> Optic
     A_Lens
     '[]
     Mint
     Mint
     (User 'IsScript 'Redemption)
     (User 'IsScript 'Redemption)
-> Optic' A_Traversal '[] TxSkel (User 'IsScript 'Redemption)
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
  '[]
  Mint
  Mint
  (User 'IsScript 'Redemption)
  (User 'IsScript 'Redemption)
mintRedeemedScriptL)
  [Mint] -> Sem effs [Mint]
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Mint] -> Sem effs [Mint]) -> [Mint] -> Sem effs [Mint]
forall a b. (a -> b) -> a -> b
$
    ([Mint] -> User 'IsScript 'Redemption -> [Mint])
-> [Mint] -> [User 'IsScript 'Redemption] -> [Mint]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
      ( \[Mint]
newMints rScript :: User 'IsScript 'Redemption
rScript@(UserRedeemedScript (script -> VScript
forall script. ToVScript script => script -> VScript
toVScript -> VScript
script) TxSkelRedeemer
_) ->
          User 'IsScript 'Redemption -> [(TokenName, Integer)] -> Mint
Mint User 'IsScript 'Redemption
rScript (VScript -> [(TokenName, Integer)]
newTokens VScript
script) Mint -> [Mint] -> [Mint]
forall a. a -> [a] -> [a]
: [Mint]
newMints
      )
      []
      [User 'IsScript 'Redemption]
currencies

-- | Token duplications based on a function applied to both existing currencies and
-- token (cannot add new currencies nor new types of tokens).
existingAssetClassTokenDuplicationParams ::
  (Member Tweak effs) =>
  -- | A function returning the new amount of tokens to mint given a specific
  -- currency, token name and amount. This new amount replaces the old one.
  (VScript -> Api.TokenName -> Integer -> Integer) ->
  -- | The attacker, who receives the extra tokens.
  owner ->
  TokenDuplicationParams owner effs
existingAssetClassTokenDuplicationParams :: forall (effs :: EffectRow) owner.
Member Tweak effs =>
(VScript -> TokenName -> Integer -> Integer)
-> owner -> TokenDuplicationParams owner effs
existingAssetClassTokenDuplicationParams VScript -> TokenName -> Integer -> Integer
newTokens = Sem effs [Mint] -> owner -> TokenDuplicationParams owner effs
forall owner (effs :: EffectRow).
Sem effs [Mint] -> owner -> TokenDuplicationParams owner effs
TokenDuplicationParams (Sem effs [Mint] -> owner -> TokenDuplicationParams owner effs)
-> Sem effs [Mint] -> owner -> TokenDuplicationParams owner effs
forall a b. (a -> b) -> a -> b
$ do
  [Mint]
mints <- Optic A_Lens '[] TxSkel TxSkel [Mint] [Mint] -> Sem effs [Mint]
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 An_Iso '[] TxSkelMints TxSkelMints [Mint] [Mint]
-> Optic A_Lens '[] TxSkel TxSkel [Mint] [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
% Optic An_Iso '[] TxSkelMints TxSkelMints [Mint] [Mint]
txSkelMintsListI)
  [Mint] -> Sem effs [Mint]
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Mint] -> Sem effs [Mint]) -> [Mint] -> Sem effs [Mint]
forall a b. (a -> b) -> a -> b
$
    ([Mint] -> Mint -> [Mint]) -> [Mint] -> [Mint] -> [Mint]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl
      ( \[Mint]
newMints (Mint rScript :: User 'IsScript 'Redemption
rScript@(UserRedeemedScript (script -> VScript
forall script. ToVScript script => script -> VScript
toVScript -> VScript
script) TxSkelRedeemer
_) [(TokenName, Integer)]
tks) ->
          User 'IsScript 'Redemption -> [(TokenName, Integer)] -> Mint
Mint User 'IsScript 'Redemption
rScript (([(TokenName, Integer)]
 -> (TokenName, Integer) -> [(TokenName, Integer)])
-> [(TokenName, Integer)]
-> [(TokenName, Integer)]
-> [(TokenName, Integer)]
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 (TokenName
tk, Integer
i) -> (TokenName
tk, VScript -> TokenName -> Integer -> Integer
newTokens VScript
script TokenName
tk Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
i) (TokenName, Integer)
-> [(TokenName, Integer)] -> [(TokenName, Integer)]
forall a. a -> [a] -> [a]
: [(TokenName, Integer)]
newTks) [] [(TokenName, Integer)]
tks) Mint -> [Mint] -> [Mint]
forall a. a -> [a] -> [a]
: [Mint]
newMints
      )
      []
      [Mint]
mints

-- | This attack adds extra tokens of any kind in the minted value. The
-- additional minted value is redirected to the attacker.
tokenDuplicationAttack ::
  ( Members '[Tweak, NonDet] effs,
    IsTxSkelOutAllowedOwner owner
  ) =>
  -- | The parameters of the attack
  TokenDuplicationParams owner effs ->
  Sem effs Api.Value
tokenDuplicationAttack :: forall (effs :: EffectRow) owner.
(Members '[Tweak, NonDet] effs, IsTxSkelOutAllowedOwner owner) =>
TokenDuplicationParams owner effs -> Sem effs Value
tokenDuplicationAttack TokenDuplicationParams {owner
Sem effs [Mint]
tdpNewMints :: forall owner (effs :: EffectRow).
TokenDuplicationParams owner effs -> Sem effs [Mint]
tdpThief :: forall owner (effs :: EffectRow).
TokenDuplicationParams owner effs -> owner
tdpNewMints :: Sem effs [Mint]
tdpThief :: owner
..} = do
  -- We compute the additional minting to add.
  [Mint]
newMints <- Sem effs [Mint]
tdpNewMints
  -- We compute the total value added this way.
  let totalIncrement :: Value
totalIncrement = TxSkelMints -> Value
forall a. ToValue a => a -> Value
Script.toValue (TxSkelMints -> Value) -> TxSkelMints -> Value
forall a b. (a -> b) -> a -> b
$ Optic An_Iso '[] TxSkelMints TxSkelMints [Mint] [Mint]
-> [Mint] -> TxSkelMints
forall k (is :: IxList) t b.
Is k A_Review =>
Optic' k is t b -> b -> t
review Optic An_Iso '[] TxSkelMints TxSkelMints [Mint] [Mint]
txSkelMintsListI [Mint]
newMints
  -- We ensure the total value is positive
  Bool -> Sem effs ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Value
totalIncrement Value -> Value -> Bool
`Api.gt` Value
forall a. Monoid a => a
mempty)
  -- We add the new mints into the 'TxSkel'
  Optic A_Lens '[] TxSkel TxSkel [Mint] [Mint]
-> [Mint] -> Sem effs ()
forall (effs :: EffectRow) k a (is :: IxList).
(Member Tweak effs, Is k A_Setter, Semigroup a) =>
Optic' k is TxSkel a -> a -> Sem effs ()
appendAfterTweak (Lens' TxSkel TxSkelMints
txSkelMintsL Lens' TxSkel TxSkelMints
-> Optic An_Iso '[] TxSkelMints TxSkelMints [Mint] [Mint]
-> Optic A_Lens '[] TxSkel TxSkel [Mint] [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
% Optic An_Iso '[] TxSkelMints TxSkelMints [Mint] [Mint]
txSkelMintsListI) [Mint]
newMints
  -- We redirect the extra value to an attacker
  Optic' A_Lens '[] TxSkel [TxSkelOut] -> TxSkelOut -> Sem effs ()
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Setter) =>
Optic' k is TxSkel [a] -> a -> Sem effs ()
insertLastTweak Optic' A_Lens '[] TxSkel [TxSkelOut]
txSkelOutputsL (TxSkelOut -> Sem effs ()) -> TxSkelOut -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ owner
tdpThief owner -> 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
  -- We label the transaction by the added tokens
  Optic' A_Lens '[] TxSkel (Set TxSkelLabel)
-> TxSkelLabel -> Sem effs ()
forall (effs :: EffectRow) k a (is :: IxList).
(Members '[Tweak, NonDet] effs, Is k A_Traversal, Ord a) =>
Optic' k is TxSkel (Set a) -> a -> Sem effs ()
insertInTweak Optic' A_Lens '[] TxSkel (Set TxSkelLabel)
txSkelLabelsL (TxSkelLabel -> Sem effs ()) -> TxSkelLabel -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ TokenDuplicationLabel -> TxSkelLabel
forall x. LabelConstrs x => x -> TxSkelLabel
TxSkelLabel (TokenDuplicationLabel -> TxSkelLabel)
-> TokenDuplicationLabel -> TxSkelLabel
forall a b. (a -> b) -> a -> b
$ Value -> TokenDuplicationLabel
TokenDuplicationLabel Value
totalIncrement
  -- We return the added tokens
  Value -> Sem effs Value
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return Value
totalIncrement