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
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)) ->
(ConcreteOutput (Script.TypedValidator a) TxSkelOutDatum Api.Value (Script.Versioned Script.Script) -> Maybe (Script.TypedValidator a)) ->
(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
)
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
) =>
(ConcreteOutput (Script.TypedValidator a) TxSkelOutDatum Api.Value (Script.Versioned Script.Script) -> Bool) ->
(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