-- | 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,
    Show (Script.DatumType a),
    Api.ToData (Script.DatumType a)
  ) =>
  Optic' k is TxSkel (ConcreteOutput (Script.TypedValidator a) TxSkelOutDatum Api.Value (Script.Versioned Script.Script)) ->
  -- | Return @Just@ the new validator, or @Nothing@ if you want to leave this
  -- output unchanged.
  (ConcreteOutput (Script.TypedValidator a) TxSkelOutDatum Api.Value (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 Api.Value (Script.Versioned Script.Script)]
redirectScriptOutputTweak :: forall (m :: * -> *) k a (is :: IxList).
(MonadTweak m, Is k A_Traversal, Show (DatumType a),
 ToData (DatumType a)) =>
Optic'
  k
  is
  TxSkel
  (ConcreteOutput
     (TypedValidator a) TxSkelOutDatum Value (Versioned Script))
-> (ConcreteOutput
      (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
    -> Maybe (TypedValidator a))
-> (Integer -> Bool)
-> m [ConcreteOutput
        (TypedValidator a) TxSkelOutDatum Value (Versioned Script)]
redirectScriptOutputTweak Optic'
  k
  is
  TxSkel
  (ConcreteOutput
     (TypedValidator a) TxSkelOutDatum Value (Versioned Script))
optic ConcreteOutput
  (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
-> Maybe (TypedValidator a)
change =
  Optic'
  k
  is
  TxSkel
  (ConcreteOutput
     (TypedValidator a) TxSkelOutDatum Value (Versioned Script))
-> (ConcreteOutput
      (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
    -> Maybe
         (ConcreteOutput
            (TypedValidator a) TxSkelOutDatum Value (Versioned Script)))
-> (Integer -> Bool)
-> m [ConcreteOutput
        (TypedValidator a) TxSkelOutDatum Value (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 Value (Versioned Script))
optic
    ( \ConcreteOutput
  (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
output -> case ConcreteOutput
  (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
-> Maybe (TypedValidator a)
change ConcreteOutput
  (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
output of
        Maybe (TypedValidator a)
Nothing -> Maybe
  (ConcreteOutput
     (TypedValidator a) TxSkelOutDatum Value (Versioned Script))
forall a. Maybe a
Nothing
        Just TypedValidator a
newValidator -> ConcreteOutput
  (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
-> Maybe
     (ConcreteOutput
        (TypedValidator a) TxSkelOutDatum Value (Versioned Script))
forall a. a -> Maybe a
Just (ConcreteOutput
   (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
 -> Maybe
      (ConcreteOutput
         (TypedValidator a) TxSkelOutDatum Value (Versioned Script)))
-> ConcreteOutput
     (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
-> Maybe
     (ConcreteOutput
        (TypedValidator a) TxSkelOutDatum Value (Versioned Script))
forall a b. (a -> b) -> a -> b
$ ConcreteOutput
  (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
output ConcreteOutput
  (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
-> (ConcreteOutput
      (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
    -> ConcreteOutput
         (TypedValidator a) TxSkelOutDatum Value (Versioned Script))
-> ConcreteOutput
     (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
forall a b. a -> (a -> b) -> b
& Optic
  A_Lens
  NoIx
  (ConcreteOutput
     (TypedValidator a) TxSkelOutDatum Value (Versioned Script))
  (ConcreteOutput
     (TypedValidator a) TxSkelOutDatum Value (Versioned Script))
  (TypedValidator a)
  (TypedValidator a)
Lens'
  (ConcreteOutput
     (TypedValidator a) TxSkelOutDatum Value (Versioned Script))
  (OwnerType
     (ConcreteOutput
        (TypedValidator a) TxSkelOutDatum Value (Versioned Script)))
forall o. IsAbstractOutput o => Lens' o (OwnerType o)
outputOwnerL Optic
  A_Lens
  NoIx
  (ConcreteOutput
     (TypedValidator a) TxSkelOutDatum Value (Versioned Script))
  (ConcreteOutput
     (TypedValidator a) TxSkelOutDatum Value (Versioned Script))
  (TypedValidator a)
  (TypedValidator a)
-> TypedValidator a
-> ConcreteOutput
     (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
-> ConcreteOutput
     (TypedValidator a) TxSkelOutDatum Value (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,
    Show (Script.DatumType a),
    PrettyCooked (Script.DatumType a),
    Api.ToData (Script.DatumType a),
    Api.UnsafeFromData (Script.DatumType a),
    Api.UnsafeFromData (Script.RedeemerType a),
    Typeable (Script.DatumType a),
    Typeable a
  ) =>
  -- | Predicate to select outputs to steal, depending on the intended
  -- recipient, the datum, and the value.
  (ConcreteOutput (Script.TypedValidator a) TxSkelOutDatum Api.Value (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 Api.Value (Script.Versioned Script.Script)]
datumHijackingAttack :: forall a (m :: * -> *).
(MonadTweak m, Show (DatumType a), PrettyCooked (DatumType a),
 ToData (DatumType a), UnsafeFromData (DatumType a),
 UnsafeFromData (RedeemerType a), Typeable (DatumType a),
 Typeable a) =>
(ConcreteOutput
   (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
 -> Bool)
-> (Integer -> Bool)
-> m [ConcreteOutput
        (TypedValidator a) TxSkelOutDatum Value (Versioned Script)]
datumHijackingAttack ConcreteOutput
  (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
-> Bool
change Integer -> Bool
select = do
  [ConcreteOutput
   (TypedValidator a) TxSkelOutDatum Value (Versioned Script)]
redirected <-
    Optic'
  A_Traversal
  NoIx
  TxSkel
  (ConcreteOutput
     (TypedValidator a) TxSkelOutDatum Value (Versioned Script))
-> (ConcreteOutput
      (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
    -> Maybe (TypedValidator a))
-> (Integer -> Bool)
-> m [ConcreteOutput
        (TypedValidator a) TxSkelOutDatum Value (Versioned Script)]
forall (m :: * -> *) k a (is :: IxList).
(MonadTweak m, Is k A_Traversal, Show (DatumType a),
 ToData (DatumType a)) =>
Optic'
  k
  is
  TxSkel
  (ConcreteOutput
     (TypedValidator a) TxSkelOutDatum Value (Versioned Script))
-> (ConcreteOutput
      (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
    -> Maybe (TypedValidator a))
-> (Integer -> Bool)
-> m [ConcreteOutput
        (TypedValidator a) TxSkelOutDatum Value (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 Value (Versioned Script))
     (ConcreteOutput
        (TypedValidator a) TxSkelOutDatum Value (Versioned Script))
-> Optic'
     A_Traversal
     NoIx
     TxSkel
     (ConcreteOutput
        (TypedValidator a) TxSkelOutDatum Value (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 Value (Versioned Script))
txSkelOutOwnerTypeP @(Script.TypedValidator a))
      (\ConcreteOutput
  (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
output -> if ConcreteOutput
  (TypedValidator a) TxSkelOutDatum Value (Versioned Script)
-> Bool
change ConcreteOutput
  (TypedValidator a) TxSkelOutDatum Value (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 Value (Versioned Script)]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ConcreteOutput
   (TypedValidator a) TxSkelOutDatum Value (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 Value (Versioned Script)]
-> m [ConcreteOutput
        (TypedValidator a) TxSkelOutDatum Value (Versioned Script)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [ConcreteOutput
   (TypedValidator a) TxSkelOutDatum Value (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