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) =>
Optic' k is TxSkel (ConcreteOutput (Script.TypedValidator a) TxSkelOutDatum TxSkelOutValue (Script.Versioned Script.Script)) ->
(ConcreteOutput (Script.TypedValidator a) TxSkelOutDatum TxSkelOutValue (Script.Versioned Script.Script) -> Maybe (Script.TypedValidator a)) ->
(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
)
datumHijackingAttack ::
forall a m.
(MonadTweak m, Typeable a) =>
(ConcreteOutput (Script.TypedValidator a) TxSkelOutDatum TxSkelOutValue (Script.Versioned Script.Script) -> Bool) ->
(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