-- | This module provides an attack that modifies the datums of a 'TxSkel'.
module Cooked.Attack.DatumTampering
  ( -- * Tamper datum params
    DatumTamperingParams (..),
    allDatumTamperingParams,
    overloadDatumTamperingParams,

    -- * Tamper datum label
    DatumTamperingLabel (..),

    -- * Tamper datum attack
    datumTamperingAttack,
  )
where

import Control.Applicative
import Cooked.Pretty.Class
import Cooked.Skeleton
import Cooked.Tweak
import Optics.Core
import PlutusCore.Data qualified as PLC
import PlutusTx qualified
import Polysemy
import Polysemy.NonDet

-- | A label added to a 'TxSkel' on which a tweak tampering a datum has been
-- applied. The label contains all the datum contents that have been
-- modified, before the modification was applied.
newtype DatumTamperingLabel a = DatumTamperingLabel [a]
  deriving (Int -> DatumTamperingLabel a -> ShowS
[DatumTamperingLabel a] -> ShowS
DatumTamperingLabel a -> String
(Int -> DatumTamperingLabel a -> ShowS)
-> (DatumTamperingLabel a -> String)
-> ([DatumTamperingLabel a] -> ShowS)
-> Show (DatumTamperingLabel a)
forall a. Show a => Int -> DatumTamperingLabel a -> ShowS
forall a. Show a => [DatumTamperingLabel a] -> ShowS
forall a. Show a => DatumTamperingLabel a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> DatumTamperingLabel a -> ShowS
showsPrec :: Int -> DatumTamperingLabel a -> ShowS
$cshow :: forall a. Show a => DatumTamperingLabel a -> String
show :: DatumTamperingLabel a -> String
$cshowList :: forall a. Show a => [DatumTamperingLabel a] -> ShowS
showList :: [DatumTamperingLabel a] -> ShowS
Show, DatumTamperingLabel a -> DatumTamperingLabel a -> Bool
(DatumTamperingLabel a -> DatumTamperingLabel a -> Bool)
-> (DatumTamperingLabel a -> DatumTamperingLabel a -> Bool)
-> Eq (DatumTamperingLabel a)
forall a.
Eq a =>
DatumTamperingLabel a -> DatumTamperingLabel a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a.
Eq a =>
DatumTamperingLabel a -> DatumTamperingLabel a -> Bool
== :: DatumTamperingLabel a -> DatumTamperingLabel a -> Bool
$c/= :: forall a.
Eq a =>
DatumTamperingLabel a -> DatumTamperingLabel a -> Bool
/= :: DatumTamperingLabel a -> DatumTamperingLabel a -> Bool
Eq, Eq (DatumTamperingLabel a)
Eq (DatumTamperingLabel a) =>
(DatumTamperingLabel a -> DatumTamperingLabel a -> Ordering)
-> (DatumTamperingLabel a -> DatumTamperingLabel a -> Bool)
-> (DatumTamperingLabel a -> DatumTamperingLabel a -> Bool)
-> (DatumTamperingLabel a -> DatumTamperingLabel a -> Bool)
-> (DatumTamperingLabel a -> DatumTamperingLabel a -> Bool)
-> (DatumTamperingLabel a
    -> DatumTamperingLabel a -> DatumTamperingLabel a)
-> (DatumTamperingLabel a
    -> DatumTamperingLabel a -> DatumTamperingLabel a)
-> Ord (DatumTamperingLabel a)
DatumTamperingLabel a -> DatumTamperingLabel a -> Bool
DatumTamperingLabel a -> DatumTamperingLabel a -> Ordering
DatumTamperingLabel a
-> DatumTamperingLabel a -> DatumTamperingLabel a
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
forall a. Ord a => Eq (DatumTamperingLabel a)
forall a.
Ord a =>
DatumTamperingLabel a -> DatumTamperingLabel a -> Bool
forall a.
Ord a =>
DatumTamperingLabel a -> DatumTamperingLabel a -> Ordering
forall a.
Ord a =>
DatumTamperingLabel a
-> DatumTamperingLabel a -> DatumTamperingLabel a
$ccompare :: forall a.
Ord a =>
DatumTamperingLabel a -> DatumTamperingLabel a -> Ordering
compare :: DatumTamperingLabel a -> DatumTamperingLabel a -> Ordering
$c< :: forall a.
Ord a =>
DatumTamperingLabel a -> DatumTamperingLabel a -> Bool
< :: DatumTamperingLabel a -> DatumTamperingLabel a -> Bool
$c<= :: forall a.
Ord a =>
DatumTamperingLabel a -> DatumTamperingLabel a -> Bool
<= :: DatumTamperingLabel a -> DatumTamperingLabel a -> Bool
$c> :: forall a.
Ord a =>
DatumTamperingLabel a -> DatumTamperingLabel a -> Bool
> :: DatumTamperingLabel a -> DatumTamperingLabel a -> Bool
$c>= :: forall a.
Ord a =>
DatumTamperingLabel a -> DatumTamperingLabel a -> Bool
>= :: DatumTamperingLabel a -> DatumTamperingLabel a -> Bool
$cmax :: forall a.
Ord a =>
DatumTamperingLabel a
-> DatumTamperingLabel a -> DatumTamperingLabel a
max :: DatumTamperingLabel a
-> DatumTamperingLabel a -> DatumTamperingLabel a
$cmin :: forall a.
Ord a =>
DatumTamperingLabel a
-> DatumTamperingLabel a -> DatumTamperingLabel a
min :: DatumTamperingLabel a
-> DatumTamperingLabel a -> DatumTamperingLabel a
Ord)

instance (PrettyCooked a) => PrettyCooked (DatumTamperingLabel a) where
  prettyCookedOpt :: PrettyCookedOpts -> DatumTamperingLabel a -> DocCooked
prettyCookedOpt PrettyCookedOpts
opts (DatumTamperingLabel [a]
dats) =
    PrettyCookedOpts -> DocCooked -> DocCooked -> [a] -> DocCooked
forall a.
PrettyCookedList a =>
PrettyCookedOpts -> DocCooked -> DocCooked -> a -> DocCooked
prettyItemize PrettyCookedOpts
opts DocCooked
"Tampered Datums" DocCooked
"-" [a]
dats

-- | Parameters of the tamper datum attack
data DatumTamperingParams a b f k is
  = DatumTamperingParams
  { -- | The branching policy to use when several datums are targeted
    forall {k} a (b :: k) (f :: k -> *) k (is :: IxList).
DatumTamperingParams a b f k is -> Branching
dtpBranching :: Branching,
    -- | The optic to use to select eligible 'TxSkelOutDatum'
    forall {k} a (b :: k) (f :: k -> *) k (is :: IxList).
DatumTamperingParams a b f k is
-> Optic' k is TxSkel TxSkelOutDatum
dtpOptic :: Optic' k is TxSkel TxSkelOutDatum,
    -- | The modification to apply on targeted datums of type @a@
    forall {k} a (b :: k) (f :: k -> *) k (is :: IxList).
DatumTamperingParams a b f k is -> a -> f b
dtpModification :: a -> f b,
    -- | The selection function based on the targeted datums indexes
    forall {k} a (b :: k) (f :: k -> *) k (is :: IxList).
DatumTamperingParams a b f k is -> Int -> Bool
dtpIndexPred :: Int -> Bool
  }

-- | A tamper datum params where all the datums are considered for targets
allDatumTamperingParams ::
  forall a b f.
  Branching ->
  (a -> f b) ->
  DatumTamperingParams a b f A_Traversal '[]
allDatumTamperingParams :: forall {k} a (b :: k) (f :: k -> *).
Branching
-> (a -> f b) -> DatumTamperingParams a b f A_Traversal '[]
allDatumTamperingParams Branching
branching a -> f b
modif =
  Branching
-> Optic' A_Traversal '[] TxSkel TxSkelOutDatum
-> (a -> f b)
-> (Int -> Bool)
-> DatumTamperingParams a b f A_Traversal '[]
forall {k} a (b :: k) (f :: k -> *) k (is :: IxList).
Branching
-> Optic' k is TxSkel TxSkelOutDatum
-> (a -> f b)
-> (Int -> Bool)
-> DatumTamperingParams a b f k is
DatumTamperingParams
    Branching
branching
    (Lens' TxSkel [TxSkelOut]
txSkelOutputsL Lens' TxSkel [TxSkelOut]
-> Optic
     A_Traversal '[] [TxSkelOut] [TxSkelOut] TxSkelOut TxSkelOut
-> Optic A_Traversal '[] TxSkel TxSkel TxSkelOut TxSkelOut
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 '[] [TxSkelOut] [TxSkelOut] TxSkelOut TxSkelOut
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed Optic A_Traversal '[] TxSkel TxSkel TxSkelOut TxSkelOut
-> Optic
     A_Lens '[] TxSkelOut TxSkelOut TxSkelOutDatum TxSkelOutDatum
-> Optic' A_Traversal '[] TxSkel TxSkelOutDatum
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 '[] TxSkelOut TxSkelOut TxSkelOutDatum TxSkelOutDatum
txSkelOutDatumL)
    a -> f b
modif
    (Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | A tamper datum params where the targeted datums are overloaded with dummy
-- extra data @I 42@ at the end of their @BuiltinData@ representation. This only
-- works if the root data is either a @Constr@ or a @List@.
overloadDatumTamperingParams ::
  forall k is.
  Branching ->
  Optic' k is TxSkel TxSkelOutDatum ->
  (Int -> Bool) ->
  DatumTamperingParams PlutusTx.BuiltinData PlutusTx.BuiltinData Maybe k is
overloadDatumTamperingParams :: forall k (is :: IxList).
Branching
-> Optic' k is TxSkel TxSkelOutDatum
-> (Int -> Bool)
-> DatumTamperingParams BuiltinData BuiltinData Maybe k is
overloadDatumTamperingParams Branching
branching Optic' k is TxSkel TxSkelOutDatum
optic =
  Branching
-> Optic' k is TxSkel TxSkelOutDatum
-> (BuiltinData -> Maybe BuiltinData)
-> (Int -> Bool)
-> DatumTamperingParams BuiltinData BuiltinData Maybe k is
forall {k} a (b :: k) (f :: k -> *) k (is :: IxList).
Branching
-> Optic' k is TxSkel TxSkelOutDatum
-> (a -> f b)
-> (Int -> Bool)
-> DatumTamperingParams a b f k is
DatumTamperingParams
    Branching
branching
    Optic' k is TxSkel TxSkelOutDatum
optic
    ( \(BuiltinData -> Data
PlutusTx.builtinDataToData -> Data
bData) -> case Data
bData of
        PLC.Constr Integer
i [Data]
dat -> BuiltinData -> Maybe BuiltinData
forall a. a -> Maybe a
Just (BuiltinData -> Maybe BuiltinData)
-> BuiltinData -> Maybe BuiltinData
forall a b. (a -> b) -> a -> b
$ Data -> BuiltinData
PlutusTx.dataToBuiltinData (Data -> BuiltinData) -> Data -> BuiltinData
forall a b. (a -> b) -> a -> b
$ Integer -> [Data] -> Data
PLC.Constr Integer
i ([Data] -> Data) -> [Data] -> Data
forall a b. (a -> b) -> a -> b
$ [Data]
dat [Data] -> [Data] -> [Data]
forall a. Semigroup a => a -> a -> a
<> [Integer -> Data
PLC.I Integer
42]
        PLC.List [Data]
l -> BuiltinData -> Maybe BuiltinData
forall a. a -> Maybe a
Just (BuiltinData -> Maybe BuiltinData)
-> BuiltinData -> Maybe BuiltinData
forall a b. (a -> b) -> a -> b
$ Data -> BuiltinData
PlutusTx.dataToBuiltinData (Data -> BuiltinData) -> Data -> BuiltinData
forall a b. (a -> b) -> a -> b
$ [Data] -> Data
PLC.List ([Data] -> Data) -> [Data] -> Data
forall a b. (a -> b) -> a -> b
$ [Data]
l [Data] -> [Data] -> [Data]
forall a. Semigroup a => a -> a -> a
<> [Integer -> Data
PLC.I Integer
42]
        Data
_ -> Maybe BuiltinData
forall a. Maybe a
Nothing
    )

-- | Applies a modification to all datums of type @a@ focused by a given
-- optic. Returns the list of modified datums, as they were before being
-- modified.
datumTamperingAttack ::
  forall a b f k is effs.
  ( DatumConstrs a,
    Ord a,
    DatumConstrs b,
    Foldable f,
    Alternative f,
    Is k A_Traversal,
    Members '[NonDet, Tweak] effs
  ) =>
  DatumTamperingParams a b f k is ->
  Sem effs [a]
datumTamperingAttack :: forall a b (f :: * -> *) k (is :: IxList) (effs :: EffectRow).
(DatumConstrs a, Ord a, DatumConstrs b, Foldable f, Alternative f,
 Is k A_Traversal, Members '[NonDet, Tweak] effs) =>
DatumTamperingParams a b f k is -> Sem effs [a]
datumTamperingAttack DatumTamperingParams {Optic' k is TxSkel TxSkelOutDatum
Branching
a -> f b
Int -> Bool
dtpBranching :: forall {k} a (b :: k) (f :: k -> *) k (is :: IxList).
DatumTamperingParams a b f k is -> Branching
dtpOptic :: forall {k} a (b :: k) (f :: k -> *) k (is :: IxList).
DatumTamperingParams a b f k is
-> Optic' k is TxSkel TxSkelOutDatum
dtpModification :: forall {k} a (b :: k) (f :: k -> *) k (is :: IxList).
DatumTamperingParams a b f k is -> a -> f b
dtpIndexPred :: forall {k} a (b :: k) (f :: k -> *) k (is :: IxList).
DatumTamperingParams a b f k is -> Int -> Bool
dtpBranching :: Branching
dtpOptic :: Optic' k is TxSkel TxSkelOutDatum
dtpModification :: a -> f b
dtpIndexPred :: Int -> Bool
..} = do
  [a]
modified <-
    ModifyTweakParams k An_AffineTraversal is '[] f TxSkelOutDatum a b
-> Sem effs [a]
forall (effs :: EffectRow) k k' (f :: * -> *) (is :: IxList)
       (is' :: IxList) a b c.
(Members '[Tweak, NonDet] effs, Is k A_Traversal,
 Is k' An_AffineTraversal, Foldable f, Alternative f) =>
ModifyTweakParams k k' is is' f a b c -> Sem effs [b]
modifyTweakFromParams (ModifyTweakParams k An_AffineTraversal is '[] f TxSkelOutDatum a b
 -> Sem effs [a])
-> ModifyTweakParams
     k An_AffineTraversal is '[] f TxSkelOutDatum a b
-> Sem effs [a]
forall a b. (a -> b) -> a -> b
$
      Branching
-> Optic' k is TxSkel TxSkelOutDatum
-> Optic An_AffineTraversal '[] TxSkelOutDatum TxSkelOutDatum a b
-> (a -> f b)
-> (Int -> Bool)
-> ModifyTweakParams
     k An_AffineTraversal is '[] f TxSkelOutDatum a b
forall k (is :: IxList) a k' (is' :: IxList) b c (f :: * -> *).
Branching
-> Optic' k is TxSkel a
-> Optic k' is' a a b c
-> (b -> f c)
-> (Int -> Bool)
-> ModifyTweakParams k k' is is' f a b c
ModifyTweakParams Branching
dtpBranching Optic' k is TxSkel TxSkelOutDatum
dtpOptic Optic An_AffineTraversal '[] TxSkelOutDatum TxSkelOutDatum a b
forall a b.
(DatumConstrs a, DatumConstrs b) =>
AffineTraversal TxSkelOutDatum TxSkelOutDatum a b
txSkelOutDatumTypedAT a -> f b
dtpModification Int -> Bool
dtpIndexPred
  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
$ DatumTamperingLabel a -> TxSkelLabel
forall x. LabelConstrs x => x -> TxSkelLabel
TxSkelLabel (DatumTamperingLabel a -> TxSkelLabel)
-> DatumTamperingLabel a -> TxSkelLabel
forall a b. (a -> b) -> a -> b
$ [a] -> DatumTamperingLabel a
forall a. [a] -> DatumTamperingLabel a
DatumTamperingLabel [a]
modified
  [a] -> Sem effs [a]
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
modified