-- | This module defines an attack tampering on the validity interval of
-- transactions.
module Cooked.Attack.ValidityTampering
  ( -- * Validity tampering params
    ValidityTamperingParams (..),
    lowerExtendedValidityTamperingParams,
    lowerStrictValidityTamperingParams,
    upperExtendedValidityTamperingParams,
    upperStrictValidityTamperingParams,
    bothExtendedValidityTamperingParams,
    bothStrictValidityTamperingParams,
    intervalValidityTamperingParams,

    -- * Validity tampering label
    ValidityTamperingLabel (..),

    -- * Validity tampering attack
    validityTamperingAttack,
  )
where

import Control.Applicative
import Control.Monad
import Cooked.Pretty.Class
import Cooked.Skeleton
import Cooked.Tweak
import Ledger.Slot qualified as Ledger
import Optics.Core
import Polysemy
import Polysemy.NonDet
import Prettyprinter qualified as PP

-- | A label added to a 'TxSkel' on which a tweak tampering the validity
-- interval has been applied. The label contains the interval as it was before
-- being tampered with.
newtype ValidityTamperingLabel = ValidityTamperingLabel Ledger.SlotRange
  deriving (Int -> ValidityTamperingLabel -> ShowS
[ValidityTamperingLabel] -> ShowS
ValidityTamperingLabel -> String
(Int -> ValidityTamperingLabel -> ShowS)
-> (ValidityTamperingLabel -> String)
-> ([ValidityTamperingLabel] -> ShowS)
-> Show ValidityTamperingLabel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValidityTamperingLabel -> ShowS
showsPrec :: Int -> ValidityTamperingLabel -> ShowS
$cshow :: ValidityTamperingLabel -> String
show :: ValidityTamperingLabel -> String
$cshowList :: [ValidityTamperingLabel] -> ShowS
showList :: [ValidityTamperingLabel] -> ShowS
Show, ValidityTamperingLabel -> ValidityTamperingLabel -> Bool
(ValidityTamperingLabel -> ValidityTamperingLabel -> Bool)
-> (ValidityTamperingLabel -> ValidityTamperingLabel -> Bool)
-> Eq ValidityTamperingLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValidityTamperingLabel -> ValidityTamperingLabel -> Bool
== :: ValidityTamperingLabel -> ValidityTamperingLabel -> Bool
$c/= :: ValidityTamperingLabel -> ValidityTamperingLabel -> Bool
/= :: ValidityTamperingLabel -> ValidityTamperingLabel -> Bool
Eq)

instance Ord ValidityTamperingLabel where
  compare :: ValidityTamperingLabel -> ValidityTamperingLabel -> Ordering
compare (ValidityTamperingLabel SlotRange
s1) (ValidityTamperingLabel SlotRange
s2) =
    (Maybe Slot, Maybe Slot) -> (Maybe Slot, Maybe Slot) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
      (Optic' A_Lens NoIx SlotRange (Maybe Slot)
-> SlotRange -> Maybe Slot
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Index SlotRange -> Lens' SlotRange (Maybe (IxValue SlotRange))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index SlotRange
ValidityBound
Lower) SlotRange
s1, Optic' A_Lens NoIx SlotRange (Maybe Slot)
-> SlotRange -> Maybe Slot
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Index SlotRange -> Lens' SlotRange (Maybe (IxValue SlotRange))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index SlotRange
ValidityBound
Upper) SlotRange
s1)
      (Optic' A_Lens NoIx SlotRange (Maybe Slot)
-> SlotRange -> Maybe Slot
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Index SlotRange -> Lens' SlotRange (Maybe (IxValue SlotRange))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index SlotRange
ValidityBound
Lower) SlotRange
s2, Optic' A_Lens NoIx SlotRange (Maybe Slot)
-> SlotRange -> Maybe Slot
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Index SlotRange -> Lens' SlotRange (Maybe (IxValue SlotRange))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index SlotRange
ValidityBound
Upper) SlotRange
s2)

instance PrettyCooked ValidityTamperingLabel where
  prettyCooked :: ValidityTamperingLabel -> DocCooked
prettyCooked (ValidityTamperingLabel SlotRange
s) =
    DocCooked
"Validity tampering:" DocCooked -> DocCooked -> DocCooked
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> SlotRange -> DocCooked
forall a ann. Pretty a => a -> Doc ann
forall ann. SlotRange -> Doc ann
PP.pretty SlotRange
s

-- | Parameters of the validity tampering attack.
data ValidityTamperingParams b f k is
  = ValidityTamperingParams
  { -- | What part of the validity range to modify
    forall b (f :: * -> *) k (is :: IxList).
ValidityTamperingParams b f k is -> Optic' k is SlotRange b
vtpOptic :: Optic' k is Ledger.SlotRange b,
    -- | How to modify the targeted part
    forall b (f :: * -> *) k (is :: IxList).
ValidityTamperingParams b f k is -> b -> f b
vtpChange :: b -> f b
  }

-- | Modifies the extended (possibly infinite) lower bound of the validity
-- interval with a given tampering function.
lowerExtendedValidityTamperingParams ::
  (Maybe Ledger.Slot -> f (Maybe Ledger.Slot)) ->
  ValidityTamperingParams (Maybe Ledger.Slot) f A_Lens NoIx
lowerExtendedValidityTamperingParams :: forall (f :: * -> *).
(Maybe Slot -> f (Maybe Slot))
-> ValidityTamperingParams (Maybe Slot) f A_Lens NoIx
lowerExtendedValidityTamperingParams =
  Optic' A_Lens NoIx SlotRange (Maybe Slot)
-> (Maybe Slot -> f (Maybe Slot))
-> ValidityTamperingParams (Maybe Slot) f A_Lens NoIx
forall b (f :: * -> *) k (is :: IxList).
Optic' k is SlotRange b
-> (b -> f b) -> ValidityTamperingParams b f k is
ValidityTamperingParams (Optic' A_Lens NoIx SlotRange (Maybe Slot)
 -> (Maybe Slot -> f (Maybe Slot))
 -> ValidityTamperingParams (Maybe Slot) f A_Lens NoIx)
-> Optic' A_Lens NoIx SlotRange (Maybe Slot)
-> (Maybe Slot -> f (Maybe Slot))
-> ValidityTamperingParams (Maybe Slot) f A_Lens NoIx
forall a b. (a -> b) -> a -> b
$ Index SlotRange -> Lens' SlotRange (Maybe (IxValue SlotRange))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index SlotRange
ValidityBound
Lower

-- | Modifies the strict lower bound of the validity interval with a given
-- tampering function, failing if it is infinite.
lowerStrictValidityTamperingParams ::
  (Ledger.Slot -> f Ledger.Slot) ->
  ValidityTamperingParams Ledger.Slot f An_AffineTraversal NoIx
lowerStrictValidityTamperingParams :: forall (f :: * -> *).
(Slot -> f Slot)
-> ValidityTamperingParams Slot f An_AffineTraversal NoIx
lowerStrictValidityTamperingParams =
  Optic' An_AffineTraversal NoIx SlotRange Slot
-> (Slot -> f Slot)
-> ValidityTamperingParams Slot f An_AffineTraversal NoIx
forall b (f :: * -> *) k (is :: IxList).
Optic' k is SlotRange b
-> (b -> f b) -> ValidityTamperingParams b f k is
ValidityTamperingParams (Optic' An_AffineTraversal NoIx SlotRange Slot
 -> (Slot -> f Slot)
 -> ValidityTamperingParams Slot f An_AffineTraversal NoIx)
-> Optic' An_AffineTraversal NoIx SlotRange Slot
-> (Slot -> f Slot)
-> ValidityTamperingParams Slot f An_AffineTraversal NoIx
forall a b. (a -> b) -> a -> b
$ Index SlotRange
-> Optic' (IxKind SlotRange) NoIx SlotRange (IxValue SlotRange)
forall m. Ixed m => Index m -> Optic' (IxKind m) NoIx m (IxValue m)
ix Index SlotRange
ValidityBound
Lower

-- | Modifies the extended (possibly infinite) upper bound of the validity
-- interval with a given tampering function.
upperExtendedValidityTamperingParams ::
  (Maybe Ledger.Slot -> f (Maybe Ledger.Slot)) ->
  ValidityTamperingParams (Maybe Ledger.Slot) f A_Lens NoIx
upperExtendedValidityTamperingParams :: forall (f :: * -> *).
(Maybe Slot -> f (Maybe Slot))
-> ValidityTamperingParams (Maybe Slot) f A_Lens NoIx
upperExtendedValidityTamperingParams =
  Optic' A_Lens NoIx SlotRange (Maybe Slot)
-> (Maybe Slot -> f (Maybe Slot))
-> ValidityTamperingParams (Maybe Slot) f A_Lens NoIx
forall b (f :: * -> *) k (is :: IxList).
Optic' k is SlotRange b
-> (b -> f b) -> ValidityTamperingParams b f k is
ValidityTamperingParams (Optic' A_Lens NoIx SlotRange (Maybe Slot)
 -> (Maybe Slot -> f (Maybe Slot))
 -> ValidityTamperingParams (Maybe Slot) f A_Lens NoIx)
-> Optic' A_Lens NoIx SlotRange (Maybe Slot)
-> (Maybe Slot -> f (Maybe Slot))
-> ValidityTamperingParams (Maybe Slot) f A_Lens NoIx
forall a b. (a -> b) -> a -> b
$ Index SlotRange -> Lens' SlotRange (Maybe (IxValue SlotRange))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index SlotRange
ValidityBound
Upper

-- | Modifies the strict upper bound of the validity interval with a given
-- tampering function, failing if it is infinite.
upperStrictValidityTamperingParams ::
  (Ledger.Slot -> f Ledger.Slot) ->
  ValidityTamperingParams Ledger.Slot f An_AffineTraversal NoIx
upperStrictValidityTamperingParams :: forall (f :: * -> *).
(Slot -> f Slot)
-> ValidityTamperingParams Slot f An_AffineTraversal NoIx
upperStrictValidityTamperingParams =
  Optic' An_AffineTraversal NoIx SlotRange Slot
-> (Slot -> f Slot)
-> ValidityTamperingParams Slot f An_AffineTraversal NoIx
forall b (f :: * -> *) k (is :: IxList).
Optic' k is SlotRange b
-> (b -> f b) -> ValidityTamperingParams b f k is
ValidityTamperingParams (Optic' An_AffineTraversal NoIx SlotRange Slot
 -> (Slot -> f Slot)
 -> ValidityTamperingParams Slot f An_AffineTraversal NoIx)
-> Optic' An_AffineTraversal NoIx SlotRange Slot
-> (Slot -> f Slot)
-> ValidityTamperingParams Slot f An_AffineTraversal NoIx
forall a b. (a -> b) -> a -> b
$ Index SlotRange
-> Optic' (IxKind SlotRange) NoIx SlotRange (IxValue SlotRange)
forall m. Ixed m => Index m -> Optic' (IxKind m) NoIx m (IxValue m)
ix Index SlotRange
ValidityBound
Upper

-- | Modifies both the extended (possibly infinite) lower and upper bounds of
-- the validity interval with a given tampering function.
bothExtendedValidityTamperingParams ::
  (Maybe Ledger.Slot -> f (Maybe Ledger.Slot)) ->
  ValidityTamperingParams (Maybe Ledger.Slot) f A_Traversal NoIx
bothExtendedValidityTamperingParams :: forall (f :: * -> *).
(Maybe Slot -> f (Maybe Slot))
-> ValidityTamperingParams (Maybe Slot) f A_Traversal NoIx
bothExtendedValidityTamperingParams =
  Optic' A_Traversal NoIx SlotRange (Maybe Slot)
-> (Maybe Slot -> f (Maybe Slot))
-> ValidityTamperingParams (Maybe Slot) f A_Traversal NoIx
forall b (f :: * -> *) k (is :: IxList).
Optic' k is SlotRange b
-> (b -> f b) -> ValidityTamperingParams b f k is
ValidityTamperingParams (Optic' A_Traversal NoIx SlotRange (Maybe Slot)
 -> (Maybe Slot -> f (Maybe Slot))
 -> ValidityTamperingParams (Maybe Slot) f A_Traversal NoIx)
-> Optic' A_Traversal NoIx SlotRange (Maybe Slot)
-> (Maybe Slot -> f (Maybe Slot))
-> ValidityTamperingParams (Maybe Slot) f A_Traversal NoIx
forall a b. (a -> b) -> a -> b
$ Index SlotRange -> Lens' SlotRange (Maybe (IxValue SlotRange))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index SlotRange
ValidityBound
Lower Optic' A_Lens NoIx SlotRange (Maybe Slot)
-> Optic' A_Lens NoIx SlotRange (Maybe Slot)
-> Optic' A_Traversal NoIx SlotRange (Maybe Slot)
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` Index SlotRange -> Lens' SlotRange (Maybe (IxValue SlotRange))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index SlotRange
ValidityBound
Upper

-- | Modifies both the strict lower and upper bounds of the validity interval
-- with a given tampering function, failing if both are infinite.
bothStrictValidityTamperingParams ::
  (Ledger.Slot -> f Ledger.Slot) ->
  ValidityTamperingParams Ledger.Slot f A_Traversal NoIx
bothStrictValidityTamperingParams :: forall (f :: * -> *).
(Slot -> f Slot) -> ValidityTamperingParams Slot f A_Traversal NoIx
bothStrictValidityTamperingParams =
  Optic' A_Traversal NoIx SlotRange Slot
-> (Slot -> f Slot)
-> ValidityTamperingParams Slot f A_Traversal NoIx
forall b (f :: * -> *) k (is :: IxList).
Optic' k is SlotRange b
-> (b -> f b) -> ValidityTamperingParams b f k is
ValidityTamperingParams (Optic' A_Traversal NoIx SlotRange Slot
 -> (Slot -> f Slot)
 -> ValidityTamperingParams Slot f A_Traversal NoIx)
-> Optic' A_Traversal NoIx SlotRange Slot
-> (Slot -> f Slot)
-> ValidityTamperingParams Slot f A_Traversal NoIx
forall a b. (a -> b) -> a -> b
$ Index SlotRange
-> Optic' (IxKind SlotRange) NoIx SlotRange (IxValue SlotRange)
forall m. Ixed m => Index m -> Optic' (IxKind m) NoIx m (IxValue m)
ix Index SlotRange
ValidityBound
Lower Optic' An_AffineTraversal NoIx SlotRange Slot
-> Optic' An_AffineTraversal NoIx SlotRange Slot
-> Optic' A_Traversal NoIx SlotRange Slot
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` Index SlotRange
-> Optic' (IxKind SlotRange) NoIx SlotRange (IxValue SlotRange)
forall m. Ixed m => Index m -> Optic' (IxKind m) NoIx m (IxValue m)
ix Index SlotRange
ValidityBound
Upper

-- | Modifies the full validity interval directly
intervalValidityTamperingParams ::
  (Ledger.SlotRange -> f Ledger.SlotRange) ->
  ValidityTamperingParams Ledger.SlotRange f An_Iso NoIx
intervalValidityTamperingParams :: forall (f :: * -> *).
(SlotRange -> f SlotRange)
-> ValidityTamperingParams SlotRange f An_Iso NoIx
intervalValidityTamperingParams =
  Optic' An_Iso NoIx SlotRange SlotRange
-> (SlotRange -> f SlotRange)
-> ValidityTamperingParams SlotRange f An_Iso NoIx
forall b (f :: * -> *) k (is :: IxList).
Optic' k is SlotRange b
-> (b -> f b) -> ValidityTamperingParams b f k is
ValidityTamperingParams Optic' An_Iso NoIx SlotRange SlotRange
forall a. Iso' a a
simple

-- | The validity tampering attack attempts to tamper with the validity interval
-- of a transaction following a given set of parameters. This returns the
-- validity interval of the transaction before modification.
validityTamperingAttack ::
  ( Members '[Tweak, NonDet] effs,
    Is k A_Traversal,
    Foldable f,
    Alternative f
  ) =>
  ValidityTamperingParams a f k is ->
  Sem effs Ledger.SlotRange
validityTamperingAttack :: forall (effs :: EffectRow) k (f :: * -> *) a (is :: IxList).
(Members '[Tweak, NonDet] effs, Is k A_Traversal, Foldable f,
 Alternative f) =>
ValidityTamperingParams a f k is -> Sem effs SlotRange
validityTamperingAttack ValidityTamperingParams {Optic' k is SlotRange a
a -> f a
vtpOptic :: forall b (f :: * -> *) k (is :: IxList).
ValidityTamperingParams b f k is -> Optic' k is SlotRange b
vtpChange :: forall b (f :: * -> *) k (is :: IxList).
ValidityTamperingParams b f k is -> b -> f b
vtpOptic :: Optic' k is SlotRange a
vtpChange :: a -> f a
..} = do
  SlotRange
currentValidityRange <- Optic' A_Lens NoIx TxSkel SlotRange -> Sem effs SlotRange
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 SlotRange
txSkelValidityRangeL
  Sem effs [a] -> Sem effs ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem effs [a] -> Sem effs ()) -> Sem effs [a] -> Sem effs ()
forall a b. (a -> b) -> a -> b
$
    ModifyTweakParams A_Traversal An_Iso is NoIx f a a a
-> Sem effs [a]
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 is NoIx f a a a
 -> Sem effs [a])
-> ModifyTweakParams A_Traversal An_Iso is NoIx f a a a
-> Sem effs [a]
forall a b. (a -> b) -> a -> b
$
      Branching
-> Optic' A_Traversal is TxSkel a
-> (a -> f a)
-> ModifyTweakParams A_Traversal An_Iso is NoIx f a a a
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
OneBranchForAllFoci
        (Optic' A_Lens NoIx TxSkel SlotRange
txSkelValidityRangeL Optic' A_Lens NoIx TxSkel SlotRange
-> Optic A_Traversal is SlotRange SlotRange a a
-> Optic' A_Traversal is TxSkel a
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 destKind srcKind (is :: IxList) s t a b.
Is srcKind destKind =>
Optic srcKind is s t a b -> Optic destKind is s t a b
castOptic @A_Traversal Optic' k is SlotRange a
vtpOptic)
        a -> f a
vtpChange
  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
$ ValidityTamperingLabel -> TxSkelLabel
forall x. LabelConstrs x => x -> TxSkelLabel
TxSkelLabel (ValidityTamperingLabel -> TxSkelLabel)
-> ValidityTamperingLabel -> TxSkelLabel
forall a b. (a -> b) -> a -> b
$ SlotRange -> ValidityTamperingLabel
ValidityTamperingLabel SlotRange
currentValidityRange
  SlotRange -> Sem effs SlotRange
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return SlotRange
currentValidityRange