-- | This module provides an automated attack to try and redirect outputs to a
-- certain target with a similar datum type.
module Cooked.Attack.DatumHijacking
  ( redirectScriptOutputTweak,
    datumHijackingAttack,
    DatumHijackingLbl (..),
  )
where

import Control.Monad
import Cooked.Output
import Cooked.Pretty.Class
import Cooked.Skeleton
import Cooked.Tweak
import Cooked.Validators
import Optics.Core
import Plutus.Script.Utils.Scripts qualified as Script
import Plutus.Script.Utils.Typed qualified as Script
import PlutusLedgerApi.V3 qualified as Api
import Prettyprinter ((<+>))
import Type.Reflection

-- | Redirect script outputs from one validator to another validator of the same
-- type. Returns the list of outputs it redirected (as they were before the
-- modification), in the order in which they occurred on the original
-- transaction.
--
-- Something like @txSkelOutsL % traversed % txSkelOutOwnerTypeP
-- @(Script.TypedValidator a)@ might be useful to construct the optics used by
-- this tweak.
redirectScriptOutputTweak ::
  (MonadTweak m, Is k A_Traversal) =>
  Optic' k is TxSkel (ConcreteOutput (Script.TypedValidator a) TxSkelOutDatum TxSkelOutValue (Script.Versioned Script.Script)) ->
  -- | Return @Just@ the new validator, or @Nothing@ if you want to leave this
  -- output unchanged.
  (ConcreteOutput (Script.TypedValidator a) TxSkelOutDatum TxSkelOutValue (Script.Versioned Script.Script) -> Maybe (Script.TypedValidator a)) ->
  -- | The redirection described by the previous argument might apply to more
  -- than one of the script outputs of the transaction. Use this predicate to
  -- select which of the redirectable script outputs to actually redirect. We
  -- count the redirectable script outputs from the left to the right, starting
  -- with zero.
  (Integer -> Bool) ->
  m [ConcreteOutput (Script.TypedValidator a) TxSkelOutDatum TxSkelOutValue (Script.Versioned Script.Script)]
redirectScriptOutputTweak :: forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Traversal) =>
Optic'
  k
  is
  TxSkel
  (ConcreteOutput
     (TypedValidator a)
     TxSkelOutDatum
     TxSkelOutValue
     (Versioned Script))
-> (ConcreteOutput
      (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
    -> Maybe (TypedValidator a))
-> (Integer -> Bool)
-> m [ConcreteOutput
        (TypedValidator a)
        TxSkelOutDatum
        TxSkelOutValue
        (Versioned Script)]
redirectScriptOutputTweak Optic'
  k
  is
  TxSkel
  (ConcreteOutput
     (TypedValidator a)
     TxSkelOutDatum
     TxSkelOutValue
     (Versioned Script))
optic ConcreteOutput
  (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
-> Maybe (TypedValidator a)
change =
  Optic'
  k
  is
  TxSkel
  (ConcreteOutput
     (TypedValidator a)
     TxSkelOutDatum
     TxSkelOutValue
     (Versioned Script))
-> (ConcreteOutput
      (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
    -> Maybe
         (ConcreteOutput
            (TypedValidator a)
            TxSkelOutDatum
            TxSkelOutValue
            (Versioned Script)))
-> (Integer -> Bool)
-> m [ConcreteOutput
        (TypedValidator a)
        TxSkelOutDatum
        TxSkelOutValue
        (Versioned Script)]
forall a (m :: * -> *) k (is :: IxList).
(MonadTweak m, Is k A_Traversal) =>
Optic' k is TxSkel a
-> (a -> Maybe a) -> (Integer -> Bool) -> m [a]
overMaybeSelectingTweak
    Optic'
  k
  is
  TxSkel
  (ConcreteOutput
     (TypedValidator a)
     TxSkelOutDatum
     TxSkelOutValue
     (Versioned Script))
optic
    ( \ConcreteOutput
  (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
output -> case ConcreteOutput
  (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
-> Maybe (TypedValidator a)
change ConcreteOutput
  (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
output of
        Maybe (TypedValidator a)
Nothing -> Maybe
  (ConcreteOutput
     (TypedValidator a)
     TxSkelOutDatum
     TxSkelOutValue
     (Versioned Script))
forall a. Maybe a
Nothing
        Just TypedValidator a
newValidator -> ConcreteOutput
  (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
-> Maybe
     (ConcreteOutput
        (TypedValidator a)
        TxSkelOutDatum
        TxSkelOutValue
        (Versioned Script))
forall a. a -> Maybe a
Just (ConcreteOutput
   (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
 -> Maybe
      (ConcreteOutput
         (TypedValidator a)
         TxSkelOutDatum
         TxSkelOutValue
         (Versioned Script)))
-> ConcreteOutput
     (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
-> Maybe
     (ConcreteOutput
        (TypedValidator a)
        TxSkelOutDatum
        TxSkelOutValue
        (Versioned Script))
forall a b. (a -> b) -> a -> b
$ ConcreteOutput
  (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
output ConcreteOutput
  (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
-> (ConcreteOutput
      (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
    -> ConcreteOutput
         (TypedValidator a)
         TxSkelOutDatum
         TxSkelOutValue
         (Versioned Script))
-> ConcreteOutput
     (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens
  NoIx
  (ConcreteOutput
     (TypedValidator a)
     TxSkelOutDatum
     TxSkelOutValue
     (Versioned Script))
  (ConcreteOutput
     (TypedValidator a)
     TxSkelOutDatum
     TxSkelOutValue
     (Versioned Script))
  (TypedValidator a)
  (TypedValidator a)
Lens'
  (ConcreteOutput
     (TypedValidator a)
     TxSkelOutDatum
     TxSkelOutValue
     (Versioned Script))
  (OwnerType
     (ConcreteOutput
        (TypedValidator a)
        TxSkelOutDatum
        TxSkelOutValue
        (Versioned Script)))
forall o. IsAbstractOutput o => Lens' o (OwnerType o)
outputOwnerL Optic
  A_Lens
  NoIx
  (ConcreteOutput
     (TypedValidator a)
     TxSkelOutDatum
     TxSkelOutValue
     (Versioned Script))
  (ConcreteOutput
     (TypedValidator a)
     TxSkelOutDatum
     TxSkelOutValue
     (Versioned Script))
  (TypedValidator a)
  (TypedValidator a)
-> TypedValidator a
-> ConcreteOutput
     (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
-> ConcreteOutput
     (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ TypedValidator a
newValidator
    )

-- | A datum hijacking attack, simplified: This attack tries to substitute a
-- different recipient on 'PaysScript' constraints, but leaves the datum as it
-- is. That is, it tests for careless uses of something like 'txInfoOutputs' in
-- places where something like 'getContinuingOutputs' should be used. If this
-- attack goes through, however, a "proper" datum hijacking attack that modifies
-- the datum in a way that (the relevant part of) the
-- 'toBuiltinData'-translation stays the same will also work.
--
-- A 'DatumHijackingLbl' with the hash of the "thief" validator is added to the
-- labels of the 'TxSkel' using 'addLabel'.
--
-- This attack returns the list of outputs it redirected, in the order in which
-- they occurred on the original transaction. If no output is redirected, this
-- attack fails.
datumHijackingAttack ::
  forall a m.
  (MonadTweak m, Typeable a) =>
  -- | Predicate to select outputs to steal, depending on the intended
  -- recipient, the datum, and the value.
  (ConcreteOutput (Script.TypedValidator a) TxSkelOutDatum TxSkelOutValue (Script.Versioned Script.Script) -> Bool) ->
  -- | The selection predicate may match more than one output. Use this
  -- predicate to restrict to the i-th of the outputs (counting from the left,
  -- starting at zero) chosen by the selection predicate with this predicate.
  (Integer -> Bool) ->
  m [ConcreteOutput (Script.TypedValidator a) TxSkelOutDatum TxSkelOutValue (Script.Versioned Script.Script)]
datumHijackingAttack :: forall a (m :: * -> *).
(MonadTweak m, Typeable a) =>
(ConcreteOutput
   (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
 -> Bool)
-> (Integer -> Bool)
-> m [ConcreteOutput
        (TypedValidator a)
        TxSkelOutDatum
        TxSkelOutValue
        (Versioned Script)]
datumHijackingAttack ConcreteOutput
  (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
-> Bool
change Integer -> Bool
select = do
  [ConcreteOutput
   (TypedValidator a)
   TxSkelOutDatum
   TxSkelOutValue
   (Versioned Script)]
redirected <-
    Optic'
  A_Traversal
  NoIx
  TxSkel
  (ConcreteOutput
     (TypedValidator a)
     TxSkelOutDatum
     TxSkelOutValue
     (Versioned Script))
-> (ConcreteOutput
      (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
    -> Maybe (TypedValidator a))
-> (Integer -> Bool)
-> m [ConcreteOutput
        (TypedValidator a)
        TxSkelOutDatum
        TxSkelOutValue
        (Versioned Script)]
forall (m :: * -> *) k (is :: IxList) a.
(MonadTweak m, Is k A_Traversal) =>
Optic'
  k
  is
  TxSkel
  (ConcreteOutput
     (TypedValidator a)
     TxSkelOutDatum
     TxSkelOutValue
     (Versioned Script))
-> (ConcreteOutput
      (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
    -> Maybe (TypedValidator a))
-> (Integer -> Bool)
-> m [ConcreteOutput
        (TypedValidator a)
        TxSkelOutDatum
        TxSkelOutValue
        (Versioned Script)]
redirectScriptOutputTweak
      (Lens' TxSkel [TxSkelOut]
txSkelOutsL Lens' TxSkel [TxSkelOut]
-> Optic
     A_Traversal NoIx [TxSkelOut] [TxSkelOut] TxSkelOut TxSkelOut
-> Optic A_Traversal NoIx 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 NoIx [TxSkelOut] [TxSkelOut] TxSkelOut TxSkelOut
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed Optic A_Traversal NoIx TxSkel TxSkel TxSkelOut TxSkelOut
-> Optic
     A_Prism
     NoIx
     TxSkelOut
     TxSkelOut
     (ConcreteOutput
        (TypedValidator a)
        TxSkelOutDatum
        TxSkelOutValue
        (Versioned Script))
     (ConcreteOutput
        (TypedValidator a)
        TxSkelOutDatum
        TxSkelOutValue
        (Versioned Script))
-> Optic'
     A_Traversal
     NoIx
     TxSkel
     (ConcreteOutput
        (TypedValidator a)
        TxSkelOutDatum
        TxSkelOutValue
        (Versioned Script))
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
% forall ownerType.
(ToCredential ownerType, Show ownerType,
 IsTxSkelOutAllowedOwner ownerType, Typeable ownerType) =>
Prism'
  TxSkelOut
  (ConcreteOutput
     ownerType TxSkelOutDatum TxSkelOutValue (Versioned Script))
txSkelOutOwnerTypeP @(Script.TypedValidator a))
      (\ConcreteOutput
  (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
output -> if ConcreteOutput
  (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
-> Bool
change ConcreteOutput
  (TypedValidator a) TxSkelOutDatum TxSkelOutValue (Versioned Script)
output then TypedValidator a -> Maybe (TypedValidator a)
forall a. a -> Maybe a
Just TypedValidator a
thief else Maybe (TypedValidator a)
forall a. Maybe a
Nothing)
      Integer -> Bool
select
  Bool -> m ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> m ()) -> (Bool -> Bool) -> Bool -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Bool
not (Bool -> m ()) -> Bool -> m ()
forall a b. (a -> b) -> a -> b
$ [ConcreteOutput
   (TypedValidator a)
   TxSkelOutDatum
   TxSkelOutValue
   (Versioned Script)]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConcreteOutput
   (TypedValidator a)
   TxSkelOutDatum
   TxSkelOutValue
   (Versioned Script)]
redirected
  DatumHijackingLbl -> m ()
forall (m :: * -> *) x. (MonadTweak m, LabelConstrs x) => x -> m ()
addLabelTweak (DatumHijackingLbl -> m ()) -> DatumHijackingLbl -> m ()
forall a b. (a -> b) -> a -> b
$ Address -> DatumHijackingLbl
DatumHijackingLbl (Address -> DatumHijackingLbl) -> Address -> DatumHijackingLbl
forall a b. (a -> b) -> a -> b
$ TypedValidator a -> Address
forall a. TypedValidator a -> Address
Script.validatorAddress TypedValidator a
thief
  [ConcreteOutput
   (TypedValidator a)
   TxSkelOutDatum
   TxSkelOutValue
   (Versioned Script)]
-> m [ConcreteOutput
        (TypedValidator a)
        TxSkelOutDatum
        TxSkelOutValue
        (Versioned Script)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [ConcreteOutput
   (TypedValidator a)
   TxSkelOutDatum
   TxSkelOutValue
   (Versioned Script)]
redirected
  where
    thief :: TypedValidator a
thief = forall a. TypedValidator a
alwaysTrueValidator @a

newtype DatumHijackingLbl = DatumHijackingLbl Api.Address
  deriving (Int -> DatumHijackingLbl -> ShowS
[DatumHijackingLbl] -> ShowS
DatumHijackingLbl -> String
(Int -> DatumHijackingLbl -> ShowS)
-> (DatumHijackingLbl -> String)
-> ([DatumHijackingLbl] -> ShowS)
-> Show DatumHijackingLbl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DatumHijackingLbl -> ShowS
showsPrec :: Int -> DatumHijackingLbl -> ShowS
$cshow :: DatumHijackingLbl -> String
show :: DatumHijackingLbl -> String
$cshowList :: [DatumHijackingLbl] -> ShowS
showList :: [DatumHijackingLbl] -> ShowS
Show, DatumHijackingLbl -> DatumHijackingLbl -> Bool
(DatumHijackingLbl -> DatumHijackingLbl -> Bool)
-> (DatumHijackingLbl -> DatumHijackingLbl -> Bool)
-> Eq DatumHijackingLbl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DatumHijackingLbl -> DatumHijackingLbl -> Bool
== :: DatumHijackingLbl -> DatumHijackingLbl -> Bool
$c/= :: DatumHijackingLbl -> DatumHijackingLbl -> Bool
/= :: DatumHijackingLbl -> DatumHijackingLbl -> Bool
Eq, Eq DatumHijackingLbl
Eq DatumHijackingLbl =>
(DatumHijackingLbl -> DatumHijackingLbl -> Ordering)
-> (DatumHijackingLbl -> DatumHijackingLbl -> Bool)
-> (DatumHijackingLbl -> DatumHijackingLbl -> Bool)
-> (DatumHijackingLbl -> DatumHijackingLbl -> Bool)
-> (DatumHijackingLbl -> DatumHijackingLbl -> Bool)
-> (DatumHijackingLbl -> DatumHijackingLbl -> DatumHijackingLbl)
-> (DatumHijackingLbl -> DatumHijackingLbl -> DatumHijackingLbl)
-> Ord DatumHijackingLbl
DatumHijackingLbl -> DatumHijackingLbl -> Bool
DatumHijackingLbl -> DatumHijackingLbl -> Ordering
DatumHijackingLbl -> DatumHijackingLbl -> DatumHijackingLbl
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 :: DatumHijackingLbl -> DatumHijackingLbl -> Ordering
compare :: DatumHijackingLbl -> DatumHijackingLbl -> Ordering
$c< :: DatumHijackingLbl -> DatumHijackingLbl -> Bool
< :: DatumHijackingLbl -> DatumHijackingLbl -> Bool
$c<= :: DatumHijackingLbl -> DatumHijackingLbl -> Bool
<= :: DatumHijackingLbl -> DatumHijackingLbl -> Bool
$c> :: DatumHijackingLbl -> DatumHijackingLbl -> Bool
> :: DatumHijackingLbl -> DatumHijackingLbl -> Bool
$c>= :: DatumHijackingLbl -> DatumHijackingLbl -> Bool
>= :: DatumHijackingLbl -> DatumHijackingLbl -> Bool
$cmax :: DatumHijackingLbl -> DatumHijackingLbl -> DatumHijackingLbl
max :: DatumHijackingLbl -> DatumHijackingLbl -> DatumHijackingLbl
$cmin :: DatumHijackingLbl -> DatumHijackingLbl -> DatumHijackingLbl
min :: DatumHijackingLbl -> DatumHijackingLbl -> DatumHijackingLbl
Ord)

instance PrettyCooked DatumHijackingLbl where
  prettyCookedOpt :: PrettyCookedOpts -> DatumHijackingLbl -> DocCooked
prettyCookedOpt PrettyCookedOpts
opts (DatumHijackingLbl Address
address) = DocCooked
"DatumHijacking" DocCooked -> DocCooked -> DocCooked
forall ann. Doc ann -> Doc ann -> Doc ann
<+> PrettyCookedOpts -> Address -> DocCooked
forall a. PrettyCooked a => PrettyCookedOpts -> a -> DocCooked
prettyCookedOpt PrettyCookedOpts
opts Address
address