-- | This module provides an attack to replace a peer with another in every
-- possible locations in a skeleton. If the peers have different levels of
-- privileges, this can uncover vulnerabilities.
module Cooked.Attack.PeerTampering
  ( -- * Peer tampering params
    PeerTamperingParams (..),
    purePeerTamperingParams,
    singlePeerTamperingParams,
    balancingPeerTamperingParams,

    -- * Peer tampering label
    PeerTamperingLabel (..),

    -- * Peer tampering attack
    peerTamperingAttack,
  )
where

import Control.Monad
import Cooked.Pretty.Class
import Cooked.Skeleton
import Cooked.Tweak
import Optics.Core
import Plutus.Script.Utils.Address qualified as Script
import PlutusLedgerApi.V3 qualified as Api
import Polysemy
import Polysemy.NonDet

-- | A label added to a 'TxSkel' on which a tweak tampering a peer has been
-- applied. The label contains all the peers that have been replaced, as they
-- were before being replaced.
newtype PeerTamperingLabel = PeerTamperingLabel [Api.PubKeyHash]
  deriving (Int -> PeerTamperingLabel -> ShowS
[PeerTamperingLabel] -> ShowS
PeerTamperingLabel -> String
(Int -> PeerTamperingLabel -> ShowS)
-> (PeerTamperingLabel -> String)
-> ([PeerTamperingLabel] -> ShowS)
-> Show PeerTamperingLabel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PeerTamperingLabel -> ShowS
showsPrec :: Int -> PeerTamperingLabel -> ShowS
$cshow :: PeerTamperingLabel -> String
show :: PeerTamperingLabel -> String
$cshowList :: [PeerTamperingLabel] -> ShowS
showList :: [PeerTamperingLabel] -> ShowS
Show, PeerTamperingLabel -> PeerTamperingLabel -> Bool
(PeerTamperingLabel -> PeerTamperingLabel -> Bool)
-> (PeerTamperingLabel -> PeerTamperingLabel -> Bool)
-> Eq PeerTamperingLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PeerTamperingLabel -> PeerTamperingLabel -> Bool
== :: PeerTamperingLabel -> PeerTamperingLabel -> Bool
$c/= :: PeerTamperingLabel -> PeerTamperingLabel -> Bool
/= :: PeerTamperingLabel -> PeerTamperingLabel -> Bool
Eq, Eq PeerTamperingLabel
Eq PeerTamperingLabel =>
(PeerTamperingLabel -> PeerTamperingLabel -> Ordering)
-> (PeerTamperingLabel -> PeerTamperingLabel -> Bool)
-> (PeerTamperingLabel -> PeerTamperingLabel -> Bool)
-> (PeerTamperingLabel -> PeerTamperingLabel -> Bool)
-> (PeerTamperingLabel -> PeerTamperingLabel -> Bool)
-> (PeerTamperingLabel -> PeerTamperingLabel -> PeerTamperingLabel)
-> (PeerTamperingLabel -> PeerTamperingLabel -> PeerTamperingLabel)
-> Ord PeerTamperingLabel
PeerTamperingLabel -> PeerTamperingLabel -> Bool
PeerTamperingLabel -> PeerTamperingLabel -> Ordering
PeerTamperingLabel -> PeerTamperingLabel -> PeerTamperingLabel
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 :: PeerTamperingLabel -> PeerTamperingLabel -> Ordering
compare :: PeerTamperingLabel -> PeerTamperingLabel -> Ordering
$c< :: PeerTamperingLabel -> PeerTamperingLabel -> Bool
< :: PeerTamperingLabel -> PeerTamperingLabel -> Bool
$c<= :: PeerTamperingLabel -> PeerTamperingLabel -> Bool
<= :: PeerTamperingLabel -> PeerTamperingLabel -> Bool
$c> :: PeerTamperingLabel -> PeerTamperingLabel -> Bool
> :: PeerTamperingLabel -> PeerTamperingLabel -> Bool
$c>= :: PeerTamperingLabel -> PeerTamperingLabel -> Bool
>= :: PeerTamperingLabel -> PeerTamperingLabel -> Bool
$cmax :: PeerTamperingLabel -> PeerTamperingLabel -> PeerTamperingLabel
max :: PeerTamperingLabel -> PeerTamperingLabel -> PeerTamperingLabel
$cmin :: PeerTamperingLabel -> PeerTamperingLabel -> PeerTamperingLabel
min :: PeerTamperingLabel -> PeerTamperingLabel -> PeerTamperingLabel
Ord)

instance PrettyCooked PeerTamperingLabel where
  prettyCookedOpt :: PrettyCookedOpts -> PeerTamperingLabel -> DocCooked
prettyCookedOpt PrettyCookedOpts
opts (PeerTamperingLabel [PubKeyHash]
changes) =
    PrettyCookedOpts
-> DocCooked -> DocCooked -> [DocCooked] -> DocCooked
forall a.
PrettyCookedList a =>
PrettyCookedOpts -> DocCooked -> DocCooked -> a -> DocCooked
prettyItemize PrettyCookedOpts
opts DocCooked
"Modified peers" DocCooked
"-" ([DocCooked] -> DocCooked) -> [DocCooked] -> DocCooked
forall a b. (a -> b) -> a -> b
$ PrettyCookedOpts -> PubKeyHash -> DocCooked
forall a. ToHash a => PrettyCookedOpts -> a -> DocCooked
prettyHash PrettyCookedOpts
opts (PubKeyHash -> DocCooked) -> [PubKeyHash] -> [DocCooked]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PubKeyHash]
changes

-- | Parameters of the peer tampering attack
data PeerTamperingParams effs
  = PeerTamperingParams
  { -- | The branching policy to use when several peers are targeted
    forall (effs :: EffectRow). PeerTamperingParams effs -> Branching
ptpBranching :: Branching,
    -- | The peer to replace, associated with a list of replacing peers
    forall (effs :: EffectRow).
PeerTamperingParams effs -> Sem effs (PubKeyHash, [PubKeyHash])
ptpChanges :: Sem effs (Api.PubKeyHash, [Api.PubKeyHash])
  }

-- | A pure variant of 'PeerTamperingParams'
purePeerTamperingParams ::
  (Member NonDet effs) =>
  Branching ->
  [(Api.PubKeyHash, [Api.PubKeyHash])] ->
  PeerTamperingParams effs
purePeerTamperingParams :: forall (effs :: EffectRow).
Member NonDet effs =>
Branching
-> [(PubKeyHash, [PubKeyHash])] -> PeerTamperingParams effs
purePeerTamperingParams Branching
branching = Branching
-> Sem effs (PubKeyHash, [PubKeyHash]) -> PeerTamperingParams effs
forall (effs :: EffectRow).
Branching
-> Sem effs (PubKeyHash, [PubKeyHash]) -> PeerTamperingParams effs
PeerTamperingParams Branching
branching (Sem effs (PubKeyHash, [PubKeyHash]) -> PeerTamperingParams effs)
-> ([(PubKeyHash, [PubKeyHash])]
    -> Sem effs (PubKeyHash, [PubKeyHash]))
-> [(PubKeyHash, [PubKeyHash])]
-> PeerTamperingParams effs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Sem effs (PubKeyHash, [PubKeyHash])]
-> Sem effs (PubKeyHash, [PubKeyHash])
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Sem effs (PubKeyHash, [PubKeyHash])]
 -> Sem effs (PubKeyHash, [PubKeyHash]))
-> ([(PubKeyHash, [PubKeyHash])]
    -> [Sem effs (PubKeyHash, [PubKeyHash])])
-> [(PubKeyHash, [PubKeyHash])]
-> Sem effs (PubKeyHash, [PubKeyHash])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((PubKeyHash, [PubKeyHash]) -> Sem effs (PubKeyHash, [PubKeyHash]))
-> [(PubKeyHash, [PubKeyHash])]
-> [Sem effs (PubKeyHash, [PubKeyHash])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PubKeyHash, [PubKeyHash]) -> Sem effs (PubKeyHash, [PubKeyHash])
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Peer tampering params transforming a single user into another
singlePeerTamperingParams ::
  (Script.ToPubKeyHash existing, Script.ToPubKeyHash new) =>
  existing ->
  new ->
  PeerTamperingParams effs
singlePeerTamperingParams :: forall existing new (effs :: EffectRow).
(ToPubKeyHash existing, ToPubKeyHash new) =>
existing -> new -> PeerTamperingParams effs
singlePeerTamperingParams (existing -> PubKeyHash
forall a. ToPubKeyHash a => a -> PubKeyHash
Script.toPubKeyHash -> PubKeyHash
existing) (new -> PubKeyHash
forall a. ToPubKeyHash a => a -> PubKeyHash
Script.toPubKeyHash -> PubKeyHash
new) =
  Branching
-> Sem effs (PubKeyHash, [PubKeyHash]) -> PeerTamperingParams effs
forall (effs :: EffectRow).
Branching
-> Sem effs (PubKeyHash, [PubKeyHash]) -> PeerTamperingParams effs
PeerTamperingParams Branching
OneBranchPerFoci ((PubKeyHash, [PubKeyHash]) -> Sem effs (PubKeyHash, [PubKeyHash])
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (PubKeyHash
existing, [PubKeyHash
new]))

-- | Peer tampering params transforming the balancing user into another
balancingPeerTamperingParams ::
  ( Script.ToPubKeyHash new,
    Members '[Tweak, NonDet] effs
  ) =>
  new ->
  PeerTamperingParams effs
balancingPeerTamperingParams :: forall new (effs :: EffectRow).
(ToPubKeyHash new, Members '[Tweak, NonDet] effs) =>
new -> PeerTamperingParams effs
balancingPeerTamperingParams (new -> PubKeyHash
forall a. ToPubKeyHash a => a -> PubKeyHash
Script.toPubKeyHash -> PubKeyHash
new) =
  Branching
-> Sem effs (PubKeyHash, [PubKeyHash]) -> PeerTamperingParams effs
forall (effs :: EffectRow).
Branching
-> Sem effs (PubKeyHash, [PubKeyHash]) -> PeerTamperingParams effs
PeerTamperingParams Branching
OneBranchPerFoci (Sem effs (PubKeyHash, [PubKeyHash]) -> PeerTamperingParams effs)
-> Sem effs (PubKeyHash, [PubKeyHash]) -> PeerTamperingParams effs
forall a b. (a -> b) -> a -> b
$ do
    BalancingPolicy
balancingPolicy <- Optic' A_Lens NoIx TxSkel BalancingPolicy
-> Sem effs BalancingPolicy
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Getter) =>
Optic' k is TxSkel a -> Sem effs a
viewTweak (Lens' TxSkel TxSkelOpts
txSkelOptsL Lens' TxSkel TxSkelOpts
-> Optic
     A_Lens NoIx TxSkelOpts TxSkelOpts BalancingPolicy BalancingPolicy
-> Optic' A_Lens NoIx TxSkel BalancingPolicy
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_Lens NoIx TxSkelOpts TxSkelOpts BalancingPolicy BalancingPolicy
txSkelOptBalancingPolicyL)
    PubKeyHash
existing <- case BalancingPolicy
balancingPolicy of
      BalancingPolicy
BalanceWithFirstSignatory -> do
        [PubKeyHash]
signatories <- Optic' A_Traversal NoIx TxSkel PubKeyHash -> Sem effs [PubKeyHash]
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Fold) =>
Optic' k is TxSkel a -> Sem effs [a]
toListOfTweak (Lens' TxSkel [TxSkelSignatory]
txSkelSignatoriesL Lens' TxSkel [TxSkelSignatory]
-> Optic
     A_Traversal
     NoIx
     [TxSkelSignatory]
     [TxSkelSignatory]
     TxSkelSignatory
     TxSkelSignatory
-> Optic
     A_Traversal NoIx TxSkel TxSkel TxSkelSignatory TxSkelSignatory
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
  [TxSkelSignatory]
  [TxSkelSignatory]
  TxSkelSignatory
  TxSkelSignatory
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed Optic
  A_Traversal NoIx TxSkel TxSkel TxSkelSignatory TxSkelSignatory
-> Optic
     A_Lens NoIx TxSkelSignatory TxSkelSignatory PubKeyHash PubKeyHash
-> Optic' A_Traversal NoIx TxSkel PubKeyHash
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_Lens NoIx TxSkelSignatory TxSkelSignatory PubKeyHash PubKeyHash
txSkelSignatoryPubKeyHashL)
        case [PubKeyHash]
signatories of
          [] -> Sem effs PubKeyHash
forall a. Sem effs a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
          PubKeyHash
first : [PubKeyHash]
_ -> PubKeyHash -> Sem effs PubKeyHash
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return PubKeyHash
first
      BalanceWith (pkh -> PubKeyHash
forall a. ToPubKeyHash a => a -> PubKeyHash
Script.toPubKeyHash -> PubKeyHash
user) -> PubKeyHash -> Sem effs PubKeyHash
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return PubKeyHash
user
      BalancingPolicy
DoNotBalance -> Sem effs PubKeyHash
forall a. Sem effs a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
    (PubKeyHash, [PubKeyHash]) -> Sem effs (PubKeyHash, [PubKeyHash])
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (PubKeyHash
existing, [PubKeyHash
new])

-- | Attempts to change the given peer into other peers everywhere in a 'TxSkel'
-- in an attempt to uncover permission breaches.
peerTamperingAttack ::
  (Members '[Tweak, NonDet] effs) =>
  PeerTamperingParams effs ->
  Sem effs [Api.PubKeyHash]
peerTamperingAttack :: forall (effs :: EffectRow).
Members '[Tweak, NonDet] effs =>
PeerTamperingParams effs -> Sem effs [PubKeyHash]
peerTamperingAttack PeerTamperingParams {Sem effs (PubKeyHash, [PubKeyHash])
Branching
ptpBranching :: forall (effs :: EffectRow). PeerTamperingParams effs -> Branching
ptpChanges :: forall (effs :: EffectRow).
PeerTamperingParams effs -> Sem effs (PubKeyHash, [PubKeyHash])
ptpBranching :: Branching
ptpChanges :: Sem effs (PubKeyHash, [PubKeyHash])
..} = do
  (PubKeyHash
existing, [PubKeyHash]
targets) <- Sem effs (PubKeyHash, [PubKeyHash])
ptpChanges
  [PubKeyHash]
modified <-
    ModifyTweakParams
  A_Traversal An_Iso NoIx NoIx [] PubKeyHash PubKeyHash PubKeyHash
-> Sem effs [PubKeyHash]
forall (effs :: EffectRow) k k' (f :: * -> *) (is :: IxList)
       (is' :: IxList) a b c.
(Members '[Tweak, NonDet] effs, Is k A_Traversal,
 Is k' An_AffineTraversal, Foldable f, Alternative f) =>
ModifyTweakParams k k' is is' f a b c -> Sem effs [b]
modifyTweakFromParams
      (ModifyTweakParams
   A_Traversal An_Iso NoIx NoIx [] PubKeyHash PubKeyHash PubKeyHash
 -> Sem effs [PubKeyHash])
-> ModifyTweakParams
     A_Traversal An_Iso NoIx NoIx [] PubKeyHash PubKeyHash PubKeyHash
-> Sem effs [PubKeyHash]
forall a b. (a -> b) -> a -> b
$ Branching
-> Optic' A_Traversal NoIx TxSkel PubKeyHash
-> (PubKeyHash -> [PubKeyHash])
-> ModifyTweakParams
     A_Traversal An_Iso NoIx NoIx [] PubKeyHash PubKeyHash PubKeyHash
forall k (is :: IxList) a (f :: * -> *).
Branching
-> Optic' k is TxSkel a
-> (a -> f a)
-> ModifyTweakParams k An_Iso is NoIx f a a a
modifyTweakParamsNoTypeChange
        Branching
ptpBranching
        ((Traversal' TxSkel (User 'IsPubKey 'Allocation)
txSkelAllocatedPeersT Traversal' TxSkel (User 'IsPubKey 'Allocation)
-> Optic
     An_Iso
     NoIx
     (User 'IsPubKey 'Allocation)
     (User 'IsPubKey 'Allocation)
     PubKeyHash
     PubKeyHash
-> Optic' A_Traversal NoIx TxSkel PubKeyHash
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_Iso
  NoIx
  (User 'IsPubKey 'Allocation)
  (User 'IsPubKey 'Allocation)
  PubKeyHash
  PubKeyHash
forall (mode :: UserMode). Iso' (User 'IsPubKey mode) PubKeyHash
userPubKeyHashI) Optic' A_Traversal NoIx TxSkel PubKeyHash
-> Optic' A_Traversal NoIx TxSkel PubKeyHash
-> Optic' A_Traversal NoIx TxSkel PubKeyHash
forall k l (is :: IxList) s a (js :: IxList).
(Is k A_Traversal, Is l A_Traversal) =>
Optic' k is s a -> Optic' l js s a -> Traversal' s a
`adjoin` (Traversal' TxSkel (User 'IsPubKey 'Redemption)
txSkelRedeemedPeersT Traversal' TxSkel (User 'IsPubKey 'Redemption)
-> Optic
     An_Iso
     NoIx
     (User 'IsPubKey 'Redemption)
     (User 'IsPubKey 'Redemption)
     PubKeyHash
     PubKeyHash
-> Optic' A_Traversal NoIx TxSkel PubKeyHash
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_Iso
  NoIx
  (User 'IsPubKey 'Redemption)
  (User 'IsPubKey 'Redemption)
  PubKeyHash
  PubKeyHash
forall (mode :: UserMode). Iso' (User 'IsPubKey mode) PubKeyHash
userPubKeyHashI))
      ((PubKeyHash -> [PubKeyHash])
 -> ModifyTweakParams
      A_Traversal An_Iso NoIx NoIx [] PubKeyHash PubKeyHash PubKeyHash)
-> (PubKeyHash -> [PubKeyHash])
-> ModifyTweakParams
     A_Traversal An_Iso NoIx NoIx [] PubKeyHash PubKeyHash PubKeyHash
forall a b. (a -> b) -> a -> b
$ \PubKeyHash
pkh -> if PubKeyHash
pkh PubKeyHash -> PubKeyHash -> Bool
forall a. Eq a => a -> a -> Bool
== PubKeyHash
existing then [PubKeyHash]
targets else []
  Optic' A_Lens NoIx TxSkel (Set TxSkelLabel)
-> TxSkelLabel -> Sem effs ()
forall (effs :: EffectRow) k a (is :: IxList).
(Members '[Tweak, NonDet] effs, Is k A_Traversal, Ord a) =>
Optic' k is TxSkel (Set a) -> a -> Sem effs ()
insertInTweak Optic' A_Lens NoIx TxSkel (Set TxSkelLabel)
txSkelLabelsL (TxSkelLabel -> Sem effs ()) -> TxSkelLabel -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ PeerTamperingLabel -> TxSkelLabel
forall x. LabelConstrs x => x -> TxSkelLabel
TxSkelLabel (PeerTamperingLabel -> TxSkelLabel)
-> PeerTamperingLabel -> TxSkelLabel
forall a b. (a -> b) -> a -> b
$ [PubKeyHash] -> PeerTamperingLabel
PeerTamperingLabel [PubKeyHash]
modified
  [PubKeyHash] -> Sem effs [PubKeyHash]
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return [PubKeyHash]
modified