{-# LANGUAGE AllowAmbiguousTypes #-}

-- | This module provides an automated attack to try and redirect outputs to a
-- certain target with a similar datum type.
module Cooked.Attack.DatumHijacking
  ( redirectOutputTweakAll,
    DatumHijackingParams (..),
    DatumHijackingLabel (..),
    redirectOutputTweakAny,
    datumHijackingAttack,
    typedByDatumHijackingParams,
    ownedByDatumHijackingParams,
    scriptsDatumHijackingParams,
    defaultDatumHijackingParams,
    datumOfDatumHijackingParams,
    outPredDatumHijackingParams,
  )
where

import Control.Monad
import Cooked.Pretty.Class
import Cooked.Pretty.Skeleton ()
import Cooked.Skeleton
import Cooked.Tweak.Common
import Cooked.Tweak.Labels
import Data.Bifunctor
import Data.Kind (Type)
import Data.Maybe
import Data.Typeable
import Optics.Core
import Polysemy
import Polysemy.NonDet

-- | Parameters of the datum hijacking attacks. They state precisely which
-- outputs should have their owner changed, wich owner should be assigned, to
-- each of these outputs, and whether several modified outputs should be
-- combined in a single transaction, or instead spread out multiple branches.
data DatumHijackingParams where
  DatumHijackingParams ::
    (IsTxSkelOutAllowedOwner owner) =>
    { -- | Return 'Just' the new owner, or 'Nothing' if you want to leave this
      -- output unchanged.
      ()
dhpOutputPred :: TxSkelOut -> Maybe owner,
      -- | The redirection described by the previous argument might apply to more
      -- than one of the outputs of the transaction. Use this predicate to select
      -- which of the redirectable outputs to actually redirect. We count the
      -- redirectable outputs from the left to the right, starting with zero.
      DatumHijackingParams -> Integer -> Bool
dhpIndexPred :: Integer -> Bool,
      -- | Whether all the outputs targetted by the predicates should be
      -- redirected in the same transaction, or one at a time, each in a
      -- distinct transaction.
      DatumHijackingParams -> Bool
dhpAllOutputs :: Bool
    } ->
    DatumHijackingParams

-- | Targets all the outputs for which the focus of a given optic exists, and
-- redirects each of them in a separate transaction.
defaultDatumHijackingParams ::
  ( IsTxSkelOutAllowedOwner owner,
    Is k An_AffineFold
  ) =>
  Optic' k is TxSkelOut x ->
  owner ->
  DatumHijackingParams
defaultDatumHijackingParams :: forall owner k (is :: IxList) x.
(IsTxSkelOutAllowedOwner owner, Is k An_AffineFold) =>
Optic' k is TxSkelOut x -> owner -> DatumHijackingParams
defaultDatumHijackingParams Optic' k is TxSkelOut x
optic owner
thief =
  (TxSkelOut -> Maybe owner)
-> (Integer -> Bool) -> Bool -> DatumHijackingParams
forall owner.
IsTxSkelOutAllowedOwner owner =>
(TxSkelOut -> Maybe owner)
-> (Integer -> Bool) -> Bool -> DatumHijackingParams
DatumHijackingParams
    ((owner
thief owner -> Maybe x -> Maybe owner
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (Maybe x -> Maybe owner)
-> (TxSkelOut -> Maybe x) -> TxSkelOut -> Maybe owner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Optic' k is TxSkelOut x -> TxSkelOut -> Maybe x
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Maybe a
preview Optic' k is TxSkelOut x
optic)
    (Bool -> Integer -> Bool
forall a b. a -> b -> a
const Bool
True)
    Bool
False

-- | Targets all the outputs satisfying a given predicate, and redirects each of
-- them in a separate transaction.
outPredDatumHijackingParams ::
  (IsTxSkelOutAllowedOwner owner) =>
  (TxSkelOut -> Bool) ->
  owner ->
  DatumHijackingParams
outPredDatumHijackingParams :: forall owner.
IsTxSkelOutAllowedOwner owner =>
(TxSkelOut -> Bool) -> owner -> DatumHijackingParams
outPredDatumHijackingParams = Optic' An_AffineFold NoIx TxSkelOut TxSkelOut
-> owner -> DatumHijackingParams
forall owner k (is :: IxList) x.
(IsTxSkelOutAllowedOwner owner, Is k An_AffineFold) =>
Optic' k is TxSkelOut x -> owner -> DatumHijackingParams
defaultDatumHijackingParams (Optic' An_AffineFold NoIx TxSkelOut TxSkelOut
 -> owner -> DatumHijackingParams)
-> ((TxSkelOut -> Bool)
    -> Optic' An_AffineFold NoIx TxSkelOut TxSkelOut)
-> (TxSkelOut -> Bool)
-> owner
-> DatumHijackingParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxSkelOut -> Bool)
-> Optic' An_AffineFold NoIx TxSkelOut TxSkelOut
forall a. (a -> Bool) -> AffineFold a a
filtered

-- | Datum hijacking parameters targetting all the outputs owned by a certain
-- type of owner, and redirecting each of them in a separate transaction.
typedByDatumHijackingParams ::
  forall (oldOwner :: Type) owner.
  ( IsTxSkelOutAllowedOwner owner,
    Typeable oldOwner
  ) =>
  owner ->
  DatumHijackingParams
typedByDatumHijackingParams :: forall oldOwner owner.
(IsTxSkelOutAllowedOwner owner, Typeable oldOwner) =>
owner -> DatumHijackingParams
typedByDatumHijackingParams = Optic' An_AffineFold NoIx TxSkelOut oldOwner
-> owner -> DatumHijackingParams
forall owner k (is :: IxList) x.
(IsTxSkelOutAllowedOwner owner, Is k An_AffineFold) =>
Optic' k is TxSkelOut x -> owner -> DatumHijackingParams
defaultDatumHijackingParams (Lens' TxSkelOut (User 'IsEither 'Allocation)
txSkelOutOwnerL Lens' TxSkelOut (User 'IsEither 'Allocation)
-> Optic
     An_AffineFold
     NoIx
     (User 'IsEither 'Allocation)
     (User 'IsEither 'Allocation)
     oldOwner
     oldOwner
-> Optic' An_AffineFold NoIx TxSkelOut oldOwner
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 user (kind :: UserKind) (mode :: UserMode).
Typeable user =>
AffineFold (User kind mode) user
userTypedAF @oldOwner)

-- | Datum hijacking parameters targetting all the outputs owner by a given
-- user, and redirecting each of them in a separate transaction.
ownedByDatumHijackingParams ::
  forall oldOwner owner.
  ( IsTxSkelOutAllowedOwner owner,
    Typeable oldOwner,
    Eq oldOwner
  ) =>
  oldOwner ->
  owner ->
  DatumHijackingParams
ownedByDatumHijackingParams :: forall oldOwner owner.
(IsTxSkelOutAllowedOwner owner, Typeable oldOwner, Eq oldOwner) =>
oldOwner -> owner -> DatumHijackingParams
ownedByDatumHijackingParams oldOwner
user = Optic' An_AffineFold NoIx TxSkelOut oldOwner
-> owner -> DatumHijackingParams
forall owner k (is :: IxList) x.
(IsTxSkelOutAllowedOwner owner, Is k An_AffineFold) =>
Optic' k is TxSkelOut x -> owner -> DatumHijackingParams
defaultDatumHijackingParams (Lens' TxSkelOut (User 'IsEither 'Allocation)
txSkelOutOwnerL Lens' TxSkelOut (User 'IsEither 'Allocation)
-> Optic
     An_AffineFold
     NoIx
     (User 'IsEither 'Allocation)
     (User 'IsEither 'Allocation)
     oldOwner
     oldOwner
-> Optic' An_AffineFold NoIx TxSkelOut oldOwner
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 user (kind :: UserKind) (mode :: UserMode).
Typeable user =>
AffineFold (User kind mode) user
userTypedAF @oldOwner Optic' An_AffineFold NoIx TxSkelOut oldOwner
-> Optic An_AffineFold NoIx oldOwner oldOwner oldOwner oldOwner
-> Optic' An_AffineFold NoIx TxSkelOut oldOwner
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
% (oldOwner -> Bool)
-> Optic An_AffineFold NoIx oldOwner oldOwner oldOwner oldOwner
forall a. (a -> Bool) -> AffineFold a a
filtered (oldOwner -> oldOwner -> Bool
forall a. Eq a => a -> a -> Bool
== oldOwner
user))

-- | Datum hijacking parameters targetting all the outputs owned by a script,
-- and redirecting each of them in a separate transaction.
scriptsDatumHijackingParams ::
  (IsTxSkelOutAllowedOwner owner) =>
  owner ->
  DatumHijackingParams
scriptsDatumHijackingParams :: forall owner.
IsTxSkelOutAllowedOwner owner =>
owner -> DatumHijackingParams
scriptsDatumHijackingParams = Optic' An_AffineFold NoIx TxSkelOut ScriptHash
-> owner -> DatumHijackingParams
forall owner k (is :: IxList) x.
(IsTxSkelOutAllowedOwner owner, Is k An_AffineFold) =>
Optic' k is TxSkelOut x -> owner -> DatumHijackingParams
defaultDatumHijackingParams (Lens' TxSkelOut (User 'IsEither 'Allocation)
txSkelOutOwnerL Lens' TxSkelOut (User 'IsEither 'Allocation)
-> Optic
     An_AffineFold
     NoIx
     (User 'IsEither 'Allocation)
     (User 'IsEither 'Allocation)
     ScriptHash
     ScriptHash
-> Optic' An_AffineFold NoIx TxSkelOut ScriptHash
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
  An_AffineFold
  NoIx
  (User 'IsEither 'Allocation)
  (User 'IsEither 'Allocation)
  ScriptHash
  ScriptHash
forall (kind :: UserKind) (mode :: UserMode).
AffineFold (User kind mode) ScriptHash
userScriptHashAF)

-- | Datum hijacking parameters targetting all the outputs with a certain type
-- of datum, and redirecting each of them in a separate transaction.
datumOfDatumHijackingParams ::
  forall dat owner.
  ( IsTxSkelOutAllowedOwner owner,
    DatumConstrs dat
  ) =>
  owner ->
  DatumHijackingParams
datumOfDatumHijackingParams :: forall dat owner.
(IsTxSkelOutAllowedOwner owner, DatumConstrs dat) =>
owner -> DatumHijackingParams
datumOfDatumHijackingParams = Optic' An_AffineTraversal NoIx TxSkelOut dat
-> owner -> DatumHijackingParams
forall owner k (is :: IxList) x.
(IsTxSkelOutAllowedOwner owner, Is k An_AffineFold) =>
Optic' k is TxSkelOut x -> owner -> DatumHijackingParams
defaultDatumHijackingParams (Lens' TxSkelOut TxSkelOutDatum
txSkelOutDatumL Lens' TxSkelOut TxSkelOutDatum
-> Optic
     An_AffineTraversal NoIx TxSkelOutDatum TxSkelOutDatum dat dat
-> Optic' An_AffineTraversal NoIx TxSkelOut dat
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 a b.
(DatumConstrs a, DatumConstrs b) =>
AffineTraversal TxSkelOutDatum TxSkelOutDatum a b
txSkelOutDatumTypedAT @dat)

-- | Redirects, in the same transaction, all the outputs targetted by an output
-- and an index predicates. See 'DatumHijackingParams' for more information on
-- those predicates. Returns the list of outputs that were successfully
-- modified, before the modification is applied.
redirectOutputTweakAll ::
  ( Member Tweak effs,
    IsTxSkelOutAllowedOwner owner
  ) =>
  (TxSkelOut -> Maybe owner) ->
  (Integer -> Bool) ->
  Sem effs [TxSkelOut]
redirectOutputTweakAll :: forall (effs :: EffectRow) owner.
(Member Tweak effs, IsTxSkelOutAllowedOwner owner) =>
(TxSkelOut -> Maybe owner)
-> (Integer -> Bool) -> Sem effs [TxSkelOut]
redirectOutputTweakAll TxSkelOut -> Maybe owner
outputPred Integer -> Bool
indexPred = do
  [TxSkelOut]
outputs <- Optic' A_Lens NoIx TxSkel [TxSkelOut] -> Sem effs [TxSkelOut]
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Getter) =>
Optic' k is TxSkel a -> Sem effs a
viewTweak Optic' A_Lens NoIx TxSkel [TxSkelOut]
txSkelOutsL
  let ([TxSkelOut]
redirected, [TxSkelOut]
newOutputs) = [TxSkelOut] -> Integer -> ([TxSkelOut], [TxSkelOut])
go [TxSkelOut]
outputs Integer
0
  Optic' A_Lens NoIx TxSkel [TxSkelOut] -> [TxSkelOut] -> Sem effs ()
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Setter) =>
Optic' k is TxSkel a -> a -> Sem effs ()
setTweak Optic' A_Lens NoIx TxSkel [TxSkelOut]
txSkelOutsL [TxSkelOut]
newOutputs
  [TxSkelOut] -> Sem effs [TxSkelOut]
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return [TxSkelOut]
redirected
  where
    go :: [TxSkelOut] -> Integer -> ([TxSkelOut], [TxSkelOut])
go [] Integer
_ = ([], [])
    go (TxSkelOut
out : [TxSkelOut]
l) Integer
n =
      case TxSkelOut -> Maybe owner
outputPred TxSkelOut
out of
        Maybe owner
Nothing -> ([TxSkelOut] -> [TxSkelOut])
-> ([TxSkelOut], [TxSkelOut]) -> ([TxSkelOut], [TxSkelOut])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (TxSkelOut
out TxSkelOut -> [TxSkelOut] -> [TxSkelOut]
forall a. a -> [a] -> [a]
:) (([TxSkelOut], [TxSkelOut]) -> ([TxSkelOut], [TxSkelOut]))
-> ([TxSkelOut], [TxSkelOut]) -> ([TxSkelOut], [TxSkelOut])
forall a b. (a -> b) -> a -> b
$ [TxSkelOut] -> Integer -> ([TxSkelOut], [TxSkelOut])
go [TxSkelOut]
l Integer
n
        Just owner
newOwner | Integer -> Bool
indexPred Integer
n -> ([TxSkelOut] -> [TxSkelOut])
-> ([TxSkelOut] -> [TxSkelOut])
-> ([TxSkelOut], [TxSkelOut])
-> ([TxSkelOut], [TxSkelOut])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (TxSkelOut
out TxSkelOut -> [TxSkelOut] -> [TxSkelOut]
forall a. a -> [a] -> [a]
:) ((TxSkelOut
out TxSkelOut -> (TxSkelOut -> TxSkelOut) -> TxSkelOut
forall a b. a -> (a -> b) -> b
& Lens' TxSkelOut (User 'IsEither 'Allocation)
txSkelOutOwnerL Lens' TxSkelOut (User 'IsEither 'Allocation)
-> User 'IsEither 'Allocation -> TxSkelOut -> TxSkelOut
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ owner -> User 'IsEither 'Allocation
forall a.
IsTxSkelOutAllowedOwner a =>
a -> User 'IsEither 'Allocation
toPKHOrVScript owner
newOwner) TxSkelOut -> [TxSkelOut] -> [TxSkelOut]
forall a. a -> [a] -> [a]
:) (([TxSkelOut], [TxSkelOut]) -> ([TxSkelOut], [TxSkelOut]))
-> ([TxSkelOut], [TxSkelOut]) -> ([TxSkelOut], [TxSkelOut])
forall a b. (a -> b) -> a -> b
$ [TxSkelOut] -> Integer -> ([TxSkelOut], [TxSkelOut])
go [TxSkelOut]
l (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)
        Maybe owner
_ -> ([TxSkelOut] -> [TxSkelOut])
-> ([TxSkelOut], [TxSkelOut]) -> ([TxSkelOut], [TxSkelOut])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (TxSkelOut
out TxSkelOut -> [TxSkelOut] -> [TxSkelOut]
forall a. a -> [a] -> [a]
:) (([TxSkelOut], [TxSkelOut]) -> ([TxSkelOut], [TxSkelOut]))
-> ([TxSkelOut], [TxSkelOut]) -> ([TxSkelOut], [TxSkelOut])
forall a b. (a -> b) -> a -> b
$ [TxSkelOut] -> Integer -> ([TxSkelOut], [TxSkelOut])
go [TxSkelOut]
l (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1)

-- | Redirects, each in their own transaction, all the outputs targetted by an
-- output and an index predicates. See 'DatumHijackingParams' for more
-- information on those predicates.
redirectOutputTweakAny ::
  ( Members '[Tweak, NonDet] effs,
    IsTxSkelOutAllowedOwner owner
  ) =>
  (TxSkelOut -> Maybe owner) ->
  (Integer -> Bool) ->
  Sem effs [TxSkelOut]
redirectOutputTweakAny :: forall (effs :: EffectRow) owner.
(Members '[Tweak, NonDet] effs, IsTxSkelOutAllowedOwner owner) =>
(TxSkelOut -> Maybe owner)
-> (Integer -> Bool) -> Sem effs [TxSkelOut]
redirectOutputTweakAny TxSkelOut -> Maybe owner
outputPred Integer -> Bool
indexPred = do
  [TxSkelOut]
outputs <- Optic' A_Lens NoIx TxSkel [TxSkelOut] -> Sem effs [TxSkelOut]
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Getter) =>
Optic' k is TxSkel a -> Sem effs a
viewTweak Optic' A_Lens NoIx TxSkel [TxSkelOut]
txSkelOutsL
  ([TxSkelOut]
redirected, [TxSkelOut]
newOutputs) <- [TxSkelOut]
-> Integer -> [TxSkelOut] -> Sem effs ([TxSkelOut], [TxSkelOut])
go [] Integer
0 [TxSkelOut]
outputs
  Optic' A_Lens NoIx TxSkel [TxSkelOut] -> [TxSkelOut] -> Sem effs ()
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Setter) =>
Optic' k is TxSkel a -> a -> Sem effs ()
setTweak Optic' A_Lens NoIx TxSkel [TxSkelOut]
txSkelOutsL [TxSkelOut]
newOutputs
  [TxSkelOut] -> Sem effs [TxSkelOut]
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return [TxSkelOut]
redirected
  where
    go :: [TxSkelOut]
-> Integer -> [TxSkelOut] -> Sem effs ([TxSkelOut], [TxSkelOut])
go [TxSkelOut]
_ Integer
_ [] = Sem effs ([TxSkelOut], [TxSkelOut])
forall a. Sem effs a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    go [TxSkelOut]
l' Integer
n (TxSkelOut
out : [TxSkelOut]
l)
      | Integer -> Bool
indexPred Integer
n =
          Sem effs ([TxSkelOut], [TxSkelOut])
-> Maybe (Sem effs ([TxSkelOut], [TxSkelOut]))
-> Sem effs ([TxSkelOut], [TxSkelOut])
forall a. a -> Maybe a -> a
fromMaybe
            ([TxSkelOut]
-> Integer -> [TxSkelOut] -> Sem effs ([TxSkelOut], [TxSkelOut])
go ([TxSkelOut]
l' [TxSkelOut] -> [TxSkelOut] -> [TxSkelOut]
forall a. [a] -> [a] -> [a]
++ [TxSkelOut
out]) (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) [TxSkelOut]
l)
            ( do
                owner
newOwner <- TxSkelOut -> Maybe owner
outputPred TxSkelOut
out
                Sem effs ([TxSkelOut], [TxSkelOut])
-> Maybe (Sem effs ([TxSkelOut], [TxSkelOut]))
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sem effs ([TxSkelOut], [TxSkelOut])
 -> Maybe (Sem effs ([TxSkelOut], [TxSkelOut])))
-> Sem effs ([TxSkelOut], [TxSkelOut])
-> Maybe (Sem effs ([TxSkelOut], [TxSkelOut]))
forall a b. (a -> b) -> a -> b
$
                  Sem effs ([TxSkelOut], [TxSkelOut])
-> Sem effs ([TxSkelOut], [TxSkelOut])
-> Sem effs ([TxSkelOut], [TxSkelOut])
forall a. Sem effs a -> Sem effs a -> Sem effs a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus
                    (([TxSkelOut], [TxSkelOut]) -> Sem effs ([TxSkelOut], [TxSkelOut])
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return ([TxSkelOut
out], [TxSkelOut]
l' [TxSkelOut] -> [TxSkelOut] -> [TxSkelOut]
forall a. [a] -> [a] -> [a]
++ (TxSkelOut
out TxSkelOut -> (TxSkelOut -> TxSkelOut) -> TxSkelOut
forall a b. a -> (a -> b) -> b
& Lens' TxSkelOut (User 'IsEither 'Allocation)
txSkelOutOwnerL Lens' TxSkelOut (User 'IsEither 'Allocation)
-> User 'IsEither 'Allocation -> TxSkelOut -> TxSkelOut
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ owner -> User 'IsEither 'Allocation
forall a.
IsTxSkelOutAllowedOwner a =>
a -> User 'IsEither 'Allocation
toPKHOrVScript owner
newOwner) TxSkelOut -> [TxSkelOut] -> [TxSkelOut]
forall a. a -> [a] -> [a]
: [TxSkelOut]
l))
                    ([TxSkelOut]
-> Integer -> [TxSkelOut] -> Sem effs ([TxSkelOut], [TxSkelOut])
go ([TxSkelOut]
l' [TxSkelOut] -> [TxSkelOut] -> [TxSkelOut]
forall a. [a] -> [a] -> [a]
++ [TxSkelOut
out]) (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1) [TxSkelOut]
l)
            )
    go [TxSkelOut]
l' Integer
n (TxSkelOut
out : [TxSkelOut]
l) = [TxSkelOut]
-> Integer -> [TxSkelOut] -> Sem effs ([TxSkelOut], [TxSkelOut])
go ([TxSkelOut]
l' [TxSkelOut] -> [TxSkelOut] -> [TxSkelOut]
forall a. [a] -> [a] -> [a]
++ [TxSkelOut
out]) Integer
n [TxSkelOut]
l

-- | The 'DatumHijackingLabel' stores the outputs that have been redirected,
-- before their destination were changed.
newtype DatumHijackingLabel = DatumHijackingLabel [TxSkelOut]
  deriving (Int -> DatumHijackingLabel -> ShowS
[DatumHijackingLabel] -> ShowS
DatumHijackingLabel -> String
(Int -> DatumHijackingLabel -> ShowS)
-> (DatumHijackingLabel -> String)
-> ([DatumHijackingLabel] -> ShowS)
-> Show DatumHijackingLabel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DatumHijackingLabel -> ShowS
showsPrec :: Int -> DatumHijackingLabel -> ShowS
$cshow :: DatumHijackingLabel -> String
show :: DatumHijackingLabel -> String
$cshowList :: [DatumHijackingLabel] -> ShowS
showList :: [DatumHijackingLabel] -> ShowS
Show, DatumHijackingLabel -> DatumHijackingLabel -> Bool
(DatumHijackingLabel -> DatumHijackingLabel -> Bool)
-> (DatumHijackingLabel -> DatumHijackingLabel -> Bool)
-> Eq DatumHijackingLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DatumHijackingLabel -> DatumHijackingLabel -> Bool
== :: DatumHijackingLabel -> DatumHijackingLabel -> Bool
$c/= :: DatumHijackingLabel -> DatumHijackingLabel -> Bool
/= :: DatumHijackingLabel -> DatumHijackingLabel -> Bool
Eq, Eq DatumHijackingLabel
Eq DatumHijackingLabel =>
(DatumHijackingLabel -> DatumHijackingLabel -> Ordering)
-> (DatumHijackingLabel -> DatumHijackingLabel -> Bool)
-> (DatumHijackingLabel -> DatumHijackingLabel -> Bool)
-> (DatumHijackingLabel -> DatumHijackingLabel -> Bool)
-> (DatumHijackingLabel -> DatumHijackingLabel -> Bool)
-> (DatumHijackingLabel
    -> DatumHijackingLabel -> DatumHijackingLabel)
-> (DatumHijackingLabel
    -> DatumHijackingLabel -> DatumHijackingLabel)
-> Ord DatumHijackingLabel
DatumHijackingLabel -> DatumHijackingLabel -> Bool
DatumHijackingLabel -> DatumHijackingLabel -> Ordering
DatumHijackingLabel -> DatumHijackingLabel -> DatumHijackingLabel
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 :: DatumHijackingLabel -> DatumHijackingLabel -> Ordering
compare :: DatumHijackingLabel -> DatumHijackingLabel -> Ordering
$c< :: DatumHijackingLabel -> DatumHijackingLabel -> Bool
< :: DatumHijackingLabel -> DatumHijackingLabel -> Bool
$c<= :: DatumHijackingLabel -> DatumHijackingLabel -> Bool
<= :: DatumHijackingLabel -> DatumHijackingLabel -> Bool
$c> :: DatumHijackingLabel -> DatumHijackingLabel -> Bool
> :: DatumHijackingLabel -> DatumHijackingLabel -> Bool
$c>= :: DatumHijackingLabel -> DatumHijackingLabel -> Bool
>= :: DatumHijackingLabel -> DatumHijackingLabel -> Bool
$cmax :: DatumHijackingLabel -> DatumHijackingLabel -> DatumHijackingLabel
max :: DatumHijackingLabel -> DatumHijackingLabel -> DatumHijackingLabel
$cmin :: DatumHijackingLabel -> DatumHijackingLabel -> DatumHijackingLabel
min :: DatumHijackingLabel -> DatumHijackingLabel -> DatumHijackingLabel
Ord)

instance PrettyCooked DatumHijackingLabel where
  prettyCookedOpt :: PrettyCookedOpts -> DatumHijackingLabel -> DocCooked
prettyCookedOpt PrettyCookedOpts
opts (DatumHijackingLabel [TxSkelOut]
txSkelOuts) = PrettyCookedOpts
-> DocCooked -> DocCooked -> [TxSkelOut] -> DocCooked
forall a.
PrettyCookedList a =>
PrettyCookedOpts -> DocCooked -> DocCooked -> a -> DocCooked
prettyItemize PrettyCookedOpts
opts DocCooked
"Redirected outputs" DocCooked
"-" [TxSkelOut]
txSkelOuts

-- | The datum hijacking tries to substitute a different recipient on certain
-- outputs based on a 'DatumHijackingParams'.
--
-- A 'DatumHijackingLabel' is added to the labels of the 'TxSkel'. It contains
-- the outputs that have been redirected, which also corresponds to the returned
-- value of this tweak. The tweak fails if no such outputs have been redirected.
datumHijackingAttack ::
  (Members '[Tweak, NonDet] effs) =>
  DatumHijackingParams ->
  Sem effs [TxSkelOut]
datumHijackingAttack :: forall (effs :: EffectRow).
Members '[Tweak, NonDet] effs =>
DatumHijackingParams -> Sem effs [TxSkelOut]
datumHijackingAttack (DatumHijackingParams TxSkelOut -> Maybe owner
outputPred Integer -> Bool
indexPred Bool
mode) = do
  [TxSkelOut]
redirected <- (if Bool
mode then (TxSkelOut -> Maybe owner)
-> (Integer -> Bool) -> Sem effs [TxSkelOut]
forall (effs :: EffectRow) owner.
(Member Tweak effs, IsTxSkelOutAllowedOwner owner) =>
(TxSkelOut -> Maybe owner)
-> (Integer -> Bool) -> Sem effs [TxSkelOut]
redirectOutputTweakAll else (TxSkelOut -> Maybe owner)
-> (Integer -> Bool) -> Sem effs [TxSkelOut]
forall (effs :: EffectRow) owner.
(Members '[Tweak, NonDet] effs, IsTxSkelOutAllowedOwner owner) =>
(TxSkelOut -> Maybe owner)
-> (Integer -> Bool) -> Sem effs [TxSkelOut]
redirectOutputTweakAny) TxSkelOut -> Maybe owner
outputPred Integer -> Bool
indexPred
  Bool -> Sem effs ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Sem effs ()) -> Bool -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [TxSkelOut] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TxSkelOut]
redirected
  DatumHijackingLabel -> Sem effs ()
forall lbl (effs :: EffectRow).
(LabelConstrs lbl, Member Tweak effs) =>
lbl -> Sem effs ()
addLabelTweak (DatumHijackingLabel -> Sem effs ())
-> DatumHijackingLabel -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ [TxSkelOut] -> DatumHijackingLabel
DatumHijackingLabel [TxSkelOut]
redirected
  [TxSkelOut] -> Sem effs [TxSkelOut]
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return [TxSkelOut]
redirected