{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Allegra.Tx (
  validateTimelock,
  Tx (..),
) where

import Cardano.Ledger.Allegra.Era (AllegraEra)
import Cardano.Ledger.Allegra.PParams ()
import Cardano.Ledger.Allegra.Scripts (AllegraEraScript (..), Timelock, evalTimelock)
import Cardano.Ledger.Allegra.TxAuxData ()
import Cardano.Ledger.Allegra.TxBody (AllegraEraTxBody (..))
import Cardano.Ledger.Allegra.TxWits ()
import Cardano.Ledger.Binary (Annotator, DecCBOR (..), EncCBOR, ToCBOR)
import Cardano.Ledger.Core (
  EraTx (..),
  EraTxWits (..),
  NativeScript,
 )
import Cardano.Ledger.Keys.WitVKey (witVKeyHash)
import Cardano.Ledger.MemoBytes (EqRaw (..))
import Cardano.Ledger.Shelley.Tx (
  ShelleyTx (..),
  Tx (..),
  auxDataShelleyTxL,
  bodyShelleyTxL,
  mkBasicShelleyTx,
  shelleyMinFeeTx,
  shelleyTxEqRaw,
  sizeShelleyTxF,
  witsShelleyTxL,
 )
import Control.DeepSeq (NFData)
import qualified Data.Set as Set (map)
import GHC.Generics (Generic)
import Lens.Micro (Lens', lens, (^.))
import NoThunks.Class (NoThunks)

-- ========================================

instance EraTx AllegraEra where
  newtype Tx AllegraEra = MkAllegraTx {Tx AllegraEra -> ShelleyTx AllegraEra
unAllegraTx :: ShelleyTx AllegraEra}
    deriving newtype (Tx AllegraEra -> Tx AllegraEra -> Bool
(Tx AllegraEra -> Tx AllegraEra -> Bool)
-> (Tx AllegraEra -> Tx AllegraEra -> Bool) -> Eq (Tx AllegraEra)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tx AllegraEra -> Tx AllegraEra -> Bool
== :: Tx AllegraEra -> Tx AllegraEra -> Bool
$c/= :: Tx AllegraEra -> Tx AllegraEra -> Bool
/= :: Tx AllegraEra -> Tx AllegraEra -> Bool
Eq, Tx AllegraEra -> ()
(Tx AllegraEra -> ()) -> NFData (Tx AllegraEra)
forall a. (a -> ()) -> NFData a
$crnf :: Tx AllegraEra -> ()
rnf :: Tx AllegraEra -> ()
NFData, Context -> Tx AllegraEra -> IO (Maybe ThunkInfo)
Proxy (Tx AllegraEra) -> String
(Context -> Tx AllegraEra -> IO (Maybe ThunkInfo))
-> (Context -> Tx AllegraEra -> IO (Maybe ThunkInfo))
-> (Proxy (Tx AllegraEra) -> String)
-> NoThunks (Tx AllegraEra)
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> Tx AllegraEra -> IO (Maybe ThunkInfo)
noThunks :: Context -> Tx AllegraEra -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Tx AllegraEra -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Tx AllegraEra -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy (Tx AllegraEra) -> String
showTypeOf :: Proxy (Tx AllegraEra) -> String
NoThunks, Int -> Tx AllegraEra -> ShowS
[Tx AllegraEra] -> ShowS
Tx AllegraEra -> String
(Int -> Tx AllegraEra -> ShowS)
-> (Tx AllegraEra -> String)
-> ([Tx AllegraEra] -> ShowS)
-> Show (Tx AllegraEra)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tx AllegraEra -> ShowS
showsPrec :: Int -> Tx AllegraEra -> ShowS
$cshow :: Tx AllegraEra -> String
show :: Tx AllegraEra -> String
$cshowList :: [Tx AllegraEra] -> ShowS
showList :: [Tx AllegraEra] -> ShowS
Show, Typeable (Tx AllegraEra)
Typeable (Tx AllegraEra) =>
(Tx AllegraEra -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size)
    -> Proxy (Tx AllegraEra) -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size)
    -> Proxy [Tx AllegraEra] -> Size)
-> ToCBOR (Tx AllegraEra)
Tx AllegraEra -> Encoding
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [Tx AllegraEra] -> Size
(forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (Tx AllegraEra) -> Size
forall a.
Typeable a =>
(a -> Encoding)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. ToCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> ToCBOR a
$ctoCBOR :: Tx AllegraEra -> Encoding
toCBOR :: Tx AllegraEra -> Encoding
$cencodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (Tx AllegraEra) -> Size
encodedSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy (Tx AllegraEra) -> Size
$cencodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [Tx AllegraEra] -> Size
encodedListSizeExpr :: (forall t. ToCBOR t => Proxy t -> Size)
-> Proxy [Tx AllegraEra] -> Size
ToCBOR, Typeable (Tx AllegraEra)
Typeable (Tx AllegraEra) =>
(Tx AllegraEra -> Encoding)
-> ((forall t. EncCBOR t => Proxy t -> Size)
    -> Proxy (Tx AllegraEra) -> Size)
-> ((forall t. EncCBOR t => Proxy t -> Size)
    -> Proxy [Tx AllegraEra] -> Size)
-> EncCBOR (Tx AllegraEra)
Tx AllegraEra -> Encoding
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [Tx AllegraEra] -> Size
(forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (Tx AllegraEra) -> Size
forall a.
Typeable a =>
(a -> Encoding)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy a -> Size)
-> ((forall t. EncCBOR t => Proxy t -> Size) -> Proxy [a] -> Size)
-> EncCBOR a
$cencCBOR :: Tx AllegraEra -> Encoding
encCBOR :: Tx AllegraEra -> Encoding
$cencodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (Tx AllegraEra) -> Size
encodedSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy (Tx AllegraEra) -> Size
$cencodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [Tx AllegraEra] -> Size
encodedListSizeExpr :: (forall t. EncCBOR t => Proxy t -> Size)
-> Proxy [Tx AllegraEra] -> Size
EncCBOR)
    deriving ((forall x. Tx AllegraEra -> Rep (Tx AllegraEra) x)
-> (forall x. Rep (Tx AllegraEra) x -> Tx AllegraEra)
-> Generic (Tx AllegraEra)
forall x. Rep (Tx AllegraEra) x -> Tx AllegraEra
forall x. Tx AllegraEra -> Rep (Tx AllegraEra) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Tx AllegraEra -> Rep (Tx AllegraEra) x
from :: forall x. Tx AllegraEra -> Rep (Tx AllegraEra) x
$cto :: forall x. Rep (Tx AllegraEra) x -> Tx AllegraEra
to :: forall x. Rep (Tx AllegraEra) x -> Tx AllegraEra
Generic)

  mkBasicTx :: TxBody AllegraEra -> Tx AllegraEra
mkBasicTx = ShelleyTx AllegraEra -> Tx AllegraEra
MkAllegraTx (ShelleyTx AllegraEra -> Tx AllegraEra)
-> (TxBody AllegraEra -> ShelleyTx AllegraEra)
-> TxBody AllegraEra
-> Tx AllegraEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody AllegraEra -> ShelleyTx AllegraEra
forall era. EraTx era => TxBody era -> ShelleyTx era
mkBasicShelleyTx

  bodyTxL :: Lens' (Tx AllegraEra) (TxBody AllegraEra)
bodyTxL = (ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra))
-> Tx AllegraEra -> f (Tx AllegraEra)
Lens' (Tx AllegraEra) (ShelleyTx AllegraEra)
allegraTxL ((ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra))
 -> Tx AllegraEra -> f (Tx AllegraEra))
-> ((TxBody AllegraEra -> f (TxBody AllegraEra))
    -> ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra))
-> (TxBody AllegraEra -> f (TxBody AllegraEra))
-> Tx AllegraEra
-> f (Tx AllegraEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxBody AllegraEra -> f (TxBody AllegraEra))
-> ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra)
forall era (f :: * -> *).
Functor f =>
(TxBody era -> f (TxBody era))
-> ShelleyTx era -> f (ShelleyTx era)
bodyShelleyTxL
  {-# INLINE bodyTxL #-}

  witsTxL :: Lens' (Tx AllegraEra) (TxWits AllegraEra)
witsTxL = (ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra))
-> Tx AllegraEra -> f (Tx AllegraEra)
Lens' (Tx AllegraEra) (ShelleyTx AllegraEra)
allegraTxL ((ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra))
 -> Tx AllegraEra -> f (Tx AllegraEra))
-> ((ShelleyTxWits AllegraEra -> f (ShelleyTxWits AllegraEra))
    -> ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra))
-> (ShelleyTxWits AllegraEra -> f (ShelleyTxWits AllegraEra))
-> Tx AllegraEra
-> f (Tx AllegraEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxWits AllegraEra -> f (TxWits AllegraEra))
-> ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra)
(ShelleyTxWits AllegraEra -> f (ShelleyTxWits AllegraEra))
-> ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra)
forall era (f :: * -> *).
Functor f =>
(TxWits era -> f (TxWits era))
-> ShelleyTx era -> f (ShelleyTx era)
witsShelleyTxL
  {-# INLINE witsTxL #-}

  auxDataTxL :: Lens' (Tx AllegraEra) (StrictMaybe (TxAuxData AllegraEra))
auxDataTxL = (ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra))
-> Tx AllegraEra -> f (Tx AllegraEra)
Lens' (Tx AllegraEra) (ShelleyTx AllegraEra)
allegraTxL ((ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra))
 -> Tx AllegraEra -> f (Tx AllegraEra))
-> ((StrictMaybe (AllegraTxAuxData AllegraEra)
     -> f (StrictMaybe (AllegraTxAuxData AllegraEra)))
    -> ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra))
-> (StrictMaybe (AllegraTxAuxData AllegraEra)
    -> f (StrictMaybe (AllegraTxAuxData AllegraEra)))
-> Tx AllegraEra
-> f (Tx AllegraEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (TxAuxData AllegraEra)
 -> f (StrictMaybe (TxAuxData AllegraEra)))
-> ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra)
(StrictMaybe (AllegraTxAuxData AllegraEra)
 -> f (StrictMaybe (AllegraTxAuxData AllegraEra)))
-> ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra)
forall era (f :: * -> *).
Functor f =>
(StrictMaybe (TxAuxData era) -> f (StrictMaybe (TxAuxData era)))
-> ShelleyTx era -> f (ShelleyTx era)
auxDataShelleyTxL
  {-# INLINE auxDataTxL #-}

  sizeTxF :: SimpleGetter (Tx AllegraEra) Integer
sizeTxF = (ShelleyTx AllegraEra -> Const r (ShelleyTx AllegraEra))
-> Tx AllegraEra -> Const r (Tx AllegraEra)
Lens' (Tx AllegraEra) (ShelleyTx AllegraEra)
allegraTxL ((ShelleyTx AllegraEra -> Const r (ShelleyTx AllegraEra))
 -> Tx AllegraEra -> Const r (Tx AllegraEra))
-> ((Integer -> Const r Integer)
    -> ShelleyTx AllegraEra -> Const r (ShelleyTx AllegraEra))
-> (Integer -> Const r Integer)
-> Tx AllegraEra
-> Const r (Tx AllegraEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Const r Integer)
-> ShelleyTx AllegraEra -> Const r (ShelleyTx AllegraEra)
forall era. EraTx era => SimpleGetter (ShelleyTx era) Integer
SimpleGetter (ShelleyTx AllegraEra) Integer
sizeShelleyTxF
  {-# INLINE sizeTxF #-}

  validateNativeScript :: Tx AllegraEra -> NativeScript AllegraEra -> Bool
validateNativeScript = Tx AllegraEra -> NativeScript AllegraEra -> Bool
forall era.
(EraTx era, AllegraEraTxBody era, AllegraEraScript era,
 NativeScript era ~ Timelock era) =>
Tx era -> NativeScript era -> Bool
validateTimelock
  {-# INLINE validateNativeScript #-}

  getMinFeeTx :: PParams AllegraEra -> Tx AllegraEra -> Int -> Coin
getMinFeeTx PParams AllegraEra
pp Tx AllegraEra
tx Int
_ = PParams AllegraEra -> Tx AllegraEra -> Coin
forall era. EraTx era => PParams era -> Tx era -> Coin
shelleyMinFeeTx PParams AllegraEra
pp Tx AllegraEra
tx

instance EqRaw (Tx AllegraEra) where
  eqRaw :: Tx AllegraEra -> Tx AllegraEra -> Bool
eqRaw = Tx AllegraEra -> Tx AllegraEra -> Bool
forall era. EraTx era => Tx era -> Tx era -> Bool
shelleyTxEqRaw

instance DecCBOR (Annotator (Tx AllegraEra)) where
  decCBOR :: forall s. Decoder s (Annotator (Tx AllegraEra))
decCBOR = (ShelleyTx AllegraEra -> Tx AllegraEra)
-> Annotator (ShelleyTx AllegraEra) -> Annotator (Tx AllegraEra)
forall a b. (a -> b) -> Annotator a -> Annotator b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShelleyTx AllegraEra -> Tx AllegraEra
MkAllegraTx (Annotator (ShelleyTx AllegraEra) -> Annotator (Tx AllegraEra))
-> Decoder s (Annotator (ShelleyTx AllegraEra))
-> Decoder s (Annotator (Tx AllegraEra))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Annotator (ShelleyTx AllegraEra))
forall s. Decoder s (Annotator (ShelleyTx AllegraEra))
forall a s. DecCBOR a => Decoder s a
decCBOR

allegraTxL :: Lens' (Tx AllegraEra) (ShelleyTx AllegraEra)
allegraTxL :: Lens' (Tx AllegraEra) (ShelleyTx AllegraEra)
allegraTxL = (Tx AllegraEra -> ShelleyTx AllegraEra)
-> (Tx AllegraEra -> ShelleyTx AllegraEra -> Tx AllegraEra)
-> Lens' (Tx AllegraEra) (ShelleyTx AllegraEra)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens Tx AllegraEra -> ShelleyTx AllegraEra
unAllegraTx (\Tx AllegraEra
x ShelleyTx AllegraEra
y -> Tx AllegraEra
x {unAllegraTx = y})

-- =======================================================
-- Validating timelock scripts
-- We extract ValidityInterval from TxBody with vldtTxBodyL getter
-- We still need to correctly compute the witness set for TxBody as well.

validateTimelock ::
  (EraTx era, AllegraEraTxBody era, AllegraEraScript era, NativeScript era ~ Timelock era) =>
  Tx era -> NativeScript era -> Bool
validateTimelock :: forall era.
(EraTx era, AllegraEraTxBody era, AllegraEraScript era,
 NativeScript era ~ Timelock era) =>
Tx era -> NativeScript era -> Bool
validateTimelock Tx era
tx NativeScript era
timelock = Set (KeyHash 'Witness)
-> ValidityInterval -> NativeScript era -> Bool
forall era.
(AllegraEraScript era, NativeScript era ~ Timelock era) =>
Set (KeyHash 'Witness)
-> ValidityInterval -> NativeScript era -> Bool
evalTimelock Set (KeyHash 'Witness)
vhks (Tx era
tx Tx era
-> Getting ValidityInterval (Tx era) ValidityInterval
-> ValidityInterval
forall s a. s -> Getting a s a -> a
^. (TxBody era -> Const ValidityInterval (TxBody era))
-> Tx era -> Const ValidityInterval (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx era) (TxBody era)
bodyTxL ((TxBody era -> Const ValidityInterval (TxBody era))
 -> Tx era -> Const ValidityInterval (Tx era))
-> ((ValidityInterval -> Const ValidityInterval ValidityInterval)
    -> TxBody era -> Const ValidityInterval (TxBody era))
-> Getting ValidityInterval (Tx era) ValidityInterval
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidityInterval -> Const ValidityInterval ValidityInterval)
-> TxBody era -> Const ValidityInterval (TxBody era)
forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
Lens' (TxBody era) ValidityInterval
vldtTxBodyL) NativeScript era
timelock
  where
    vhks :: Set (KeyHash 'Witness)
vhks = (WitVKey 'Witness -> KeyHash 'Witness)
-> Set (WitVKey 'Witness) -> Set (KeyHash 'Witness)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map WitVKey 'Witness -> KeyHash 'Witness
forall (kr :: KeyRole). WitVKey kr -> KeyHash 'Witness
witVKeyHash (Tx era
tx Tx era
-> Getting
     (Set (WitVKey 'Witness)) (Tx era) (Set (WitVKey 'Witness))
-> Set (WitVKey 'Witness)
forall s a. s -> Getting a s a -> a
^. (TxWits era -> Const (Set (WitVKey 'Witness)) (TxWits era))
-> Tx era -> Const (Set (WitVKey 'Witness)) (Tx era)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx era) (TxWits era)
witsTxL ((TxWits era -> Const (Set (WitVKey 'Witness)) (TxWits era))
 -> Tx era -> Const (Set (WitVKey 'Witness)) (Tx era))
-> ((Set (WitVKey 'Witness)
     -> Const (Set (WitVKey 'Witness)) (Set (WitVKey 'Witness)))
    -> TxWits era -> Const (Set (WitVKey 'Witness)) (TxWits era))
-> Getting
     (Set (WitVKey 'Witness)) (Tx era) (Set (WitVKey 'Witness))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Set (WitVKey 'Witness)
 -> Const (Set (WitVKey 'Witness)) (Set (WitVKey 'Witness)))
-> TxWits era -> Const (Set (WitVKey 'Witness)) (TxWits era)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL)
{-# INLINEABLE validateTimelock #-}