-- | This module exposes an attack consisting in reordering the outputs of a
-- transaction, in an attempt to uncover vulnerabilities in smart contracts
-- relying on the outputs order.
module Cooked.Attack.OutputsReordering
  ( -- * Outputs reordering params
    OutputsReorderingParams (..),

    -- * Outputs reordering label
    OutputsReorderingLabel (..),

    -- * Outputs reordering attack
    outputsReorderingAttack,
  )
where

import Control.Monad
import Cooked.Pretty.Class
import Cooked.Skeleton
import Cooked.Tweak
import Data.List (permutations)
import Polysemy (Members, Sem)
import Polysemy.NonDet

-- | A label added to a 'TxSkel' on which a tweak reordering some outputs has
-- been applied.
data OutputsReorderingLabel = OutputsReorderingLabel
  deriving (Int -> OutputsReorderingLabel -> ShowS
[OutputsReorderingLabel] -> ShowS
OutputsReorderingLabel -> String
(Int -> OutputsReorderingLabel -> ShowS)
-> (OutputsReorderingLabel -> String)
-> ([OutputsReorderingLabel] -> ShowS)
-> Show OutputsReorderingLabel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OutputsReorderingLabel -> ShowS
showsPrec :: Int -> OutputsReorderingLabel -> ShowS
$cshow :: OutputsReorderingLabel -> String
show :: OutputsReorderingLabel -> String
$cshowList :: [OutputsReorderingLabel] -> ShowS
showList :: [OutputsReorderingLabel] -> ShowS
Show, OutputsReorderingLabel -> OutputsReorderingLabel -> Bool
(OutputsReorderingLabel -> OutputsReorderingLabel -> Bool)
-> (OutputsReorderingLabel -> OutputsReorderingLabel -> Bool)
-> Eq OutputsReorderingLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OutputsReorderingLabel -> OutputsReorderingLabel -> Bool
== :: OutputsReorderingLabel -> OutputsReorderingLabel -> Bool
$c/= :: OutputsReorderingLabel -> OutputsReorderingLabel -> Bool
/= :: OutputsReorderingLabel -> OutputsReorderingLabel -> Bool
Eq, Eq OutputsReorderingLabel
Eq OutputsReorderingLabel =>
(OutputsReorderingLabel -> OutputsReorderingLabel -> Ordering)
-> (OutputsReorderingLabel -> OutputsReorderingLabel -> Bool)
-> (OutputsReorderingLabel -> OutputsReorderingLabel -> Bool)
-> (OutputsReorderingLabel -> OutputsReorderingLabel -> Bool)
-> (OutputsReorderingLabel -> OutputsReorderingLabel -> Bool)
-> (OutputsReorderingLabel
    -> OutputsReorderingLabel -> OutputsReorderingLabel)
-> (OutputsReorderingLabel
    -> OutputsReorderingLabel -> OutputsReorderingLabel)
-> Ord OutputsReorderingLabel
OutputsReorderingLabel -> OutputsReorderingLabel -> Bool
OutputsReorderingLabel -> OutputsReorderingLabel -> Ordering
OutputsReorderingLabel
-> OutputsReorderingLabel -> OutputsReorderingLabel
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 :: OutputsReorderingLabel -> OutputsReorderingLabel -> Ordering
compare :: OutputsReorderingLabel -> OutputsReorderingLabel -> Ordering
$c< :: OutputsReorderingLabel -> OutputsReorderingLabel -> Bool
< :: OutputsReorderingLabel -> OutputsReorderingLabel -> Bool
$c<= :: OutputsReorderingLabel -> OutputsReorderingLabel -> Bool
<= :: OutputsReorderingLabel -> OutputsReorderingLabel -> Bool
$c> :: OutputsReorderingLabel -> OutputsReorderingLabel -> Bool
> :: OutputsReorderingLabel -> OutputsReorderingLabel -> Bool
$c>= :: OutputsReorderingLabel -> OutputsReorderingLabel -> Bool
>= :: OutputsReorderingLabel -> OutputsReorderingLabel -> Bool
$cmax :: OutputsReorderingLabel
-> OutputsReorderingLabel -> OutputsReorderingLabel
max :: OutputsReorderingLabel
-> OutputsReorderingLabel -> OutputsReorderingLabel
$cmin :: OutputsReorderingLabel
-> OutputsReorderingLabel -> OutputsReorderingLabel
min :: OutputsReorderingLabel
-> OutputsReorderingLabel -> OutputsReorderingLabel
Ord)

instance PrettyCooked OutputsReorderingLabel where
  prettyCooked :: OutputsReorderingLabel -> DocCooked
prettyCooked OutputsReorderingLabel
_ = DocCooked
"Outputs reordering"

-- | Parameters of the outputs reordering attack
data OutputsReorderingParams
  = -- | Swaps two elements in the list
    Swap Int Int
  | -- | Moves one element from a given index to a given index in the list
    Move Int Int
  | -- | Shuffle the list (generate all permutations, except the identity)
    Shuffle
  | -- | Do whatever you want with the outputs, manually, including removing
    -- some of them, or fully changing the list.
    ManualReordering (forall a. [a] -> [[a]])

-- | Reorders the outputs following a given policy (parameters) to try and
-- uncover vulnerabilities for smart contracts depending on the outputs
-- order. This can also be used to uncover some cases of double
-- satisfaction. This removes the permutations that turn out to be identical
-- to the initial outputs list.
outputsReorderingAttack ::
  (Members '[Tweak, NonDet] effs) =>
  OutputsReorderingParams ->
  Sem effs ()
outputsReorderingAttack :: forall (effs :: EffectRow).
Members '[Tweak, NonDet] effs =>
OutputsReorderingParams -> Sem effs ()
outputsReorderingAttack OutputsReorderingParams
params = 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]
txSkelOutputsL
  let iMax :: Int
iMax = [TxSkelOut] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [TxSkelOut]
outputs
  [Sem effs ()] -> Sem effs ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Sem effs ()] -> Sem effs ()) -> [Sem effs ()] -> Sem effs ()
forall a b. (a -> b) -> a -> b
$
    ([TxSkelOut] -> Sem effs ()) -> [[TxSkelOut]] -> [Sem effs ()]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (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]
txSkelOutputsL) ([[TxSkelOut]] -> [Sem effs ()]) -> [[TxSkelOut]] -> [Sem effs ()]
forall a b. (a -> b) -> a -> b
$
      ([TxSkelOut] -> Bool) -> [[TxSkelOut]] -> [[TxSkelOut]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([TxSkelOut] -> [TxSkelOut] -> Bool
forall a. Eq a => a -> a -> Bool
/= [TxSkelOut]
outputs) ([[TxSkelOut]] -> [[TxSkelOut]]) -> [[TxSkelOut]] -> [[TxSkelOut]]
forall a b. (a -> b) -> a -> b
$
        case OutputsReorderingParams
params of
          Swap Int
i Int
j
            | Int -> Int -> Bool
valid Int
i Int
iMax Bool -> Bool -> Bool
&& Int -> Int -> Bool
valid Int
j Int
iMax Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
j ->
                let (TxSkelOut
ai, TxSkelOut
aj) = ([TxSkelOut]
outputs [TxSkelOut] -> Int -> TxSkelOut
forall a. HasCallStack => [a] -> Int -> a
!! Int
i, [TxSkelOut]
outputs [TxSkelOut] -> Int -> TxSkelOut
forall a. HasCallStack => [a] -> Int -> a
!! Int
j)
                 in [Int -> TxSkelOut -> [TxSkelOut] -> [TxSkelOut]
forall {a}. Int -> a -> [a] -> [a]
replaceAt Int
i TxSkelOut
aj ([TxSkelOut] -> [TxSkelOut]) -> [TxSkelOut] -> [TxSkelOut]
forall a b. (a -> b) -> a -> b
$ Int -> TxSkelOut -> [TxSkelOut] -> [TxSkelOut]
forall {a}. Int -> a -> [a] -> [a]
replaceAt Int
j TxSkelOut
ai [TxSkelOut]
outputs]
          Move Int
i Int
j
            | Int -> Int -> Bool
valid Int
i Int
iMax Bool -> Bool -> Bool
&& Int -> Int -> Bool
valid Int
j Int
iMax Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
j ->
                let ai :: TxSkelOut
ai = [TxSkelOut]
outputs [TxSkelOut] -> Int -> TxSkelOut
forall a. HasCallStack => [a] -> Int -> a
!! Int
i
                 in [Int -> TxSkelOut -> [TxSkelOut] -> [TxSkelOut]
forall {a}. Int -> a -> [a] -> [a]
insertAt (if Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
j then Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 else Int
j) TxSkelOut
ai ([TxSkelOut] -> [TxSkelOut]) -> [TxSkelOut] -> [TxSkelOut]
forall a b. (a -> b) -> a -> b
$ Int -> [TxSkelOut] -> [TxSkelOut]
forall {a}. Int -> [a] -> [a]
removeAt Int
i [TxSkelOut]
outputs]
          OutputsReorderingParams
Shuffle -> [TxSkelOut] -> [[TxSkelOut]]
forall a. [a] -> [[a]]
permutations [TxSkelOut]
outputs
          ManualReordering forall a. [a] -> [[a]]
f -> [TxSkelOut] -> [[TxSkelOut]]
forall a. [a] -> [[a]]
f [TxSkelOut]
outputs
          OutputsReorderingParams
_ -> []
  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
$ OutputsReorderingLabel -> TxSkelLabel
forall x. LabelConstrs x => x -> TxSkelLabel
TxSkelLabel OutputsReorderingLabel
OutputsReorderingLabel
  where
    valid :: Int -> Int -> Bool
    valid :: Int -> Int -> Bool
valid Int
i Int
iMax = Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
iMax

    modifyAt :: Int -> ([a] -> [a]) -> [a] -> [a]
    modifyAt :: forall a. Int -> ([a] -> [a]) -> [a] -> [a]
modifyAt Int
0 [a] -> [a]
f [a]
l = [a] -> [a]
f [a]
l
    modifyAt Int
_ [a] -> [a]
_ [] = []
    modifyAt Int
n [a] -> [a]
f (a
x : [a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: Int -> ([a] -> [a]) -> [a] -> [a]
forall a. Int -> ([a] -> [a]) -> [a] -> [a]
modifyAt (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a] -> [a]
f [a]
xs

    replaceAt :: Int -> a -> [a] -> [a]
replaceAt Int
n a
a = Int -> ([a] -> [a]) -> [a] -> [a]
forall a. Int -> ([a] -> [a]) -> [a] -> [a]
modifyAt Int
n (([a] -> [a]) -> [a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ \case [] -> []; (a
_ : [a]
xs) -> a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
xs

    removeAt :: Int -> [a] -> [a]
removeAt Int
n = Int -> ([a] -> [a]) -> [a] -> [a]
forall a. Int -> ([a] -> [a]) -> [a] -> [a]
modifyAt Int
n (([a] -> [a]) -> [a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ \case [] -> []; (a
_ : [a]
xs) -> [a]
xs

    insertAt :: Int -> a -> [a] -> [a]
insertAt Int
n a
a = Int -> ([a] -> [a]) -> [a] -> [a]
forall a. Int -> ([a] -> [a]) -> [a] -> [a]
modifyAt Int
n (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)