{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

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

import Cardano.Ledger.Allegra.Era (AllegraEra)
import Cardano.Ledger.Allegra.PParams ()
import Cardano.Ledger.Allegra.Scripts (AllegraEraScript (..), evalTimelock)
import Cardano.Ledger.Allegra.TxAuxData ()
import Cardano.Ledger.Allegra.TxBody (AllegraEraTxBody (..))
import Cardano.Ledger.Allegra.TxWits ()
import Cardano.Ledger.Core (
  EraTx (..),
  EraTxAuxData (upgradeTxAuxData),
  EraTxWits (..),
  NativeScript,
  upgradeTxBody,
 )
import Cardano.Ledger.Keys.WitVKey (witVKeyHash)
import Cardano.Ledger.Shelley.Tx (
  ShelleyTx (..),
  auxDataShelleyTxL,
  bodyShelleyTxL,
  mkBasicShelleyTx,
  shelleyMinFeeTx,
  sizeShelleyTxF,
  wireSizeShelleyTxF,
  witsShelleyTxL,
 )
import qualified Data.Set as Set (map)
import Lens.Micro ((^.))

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

instance EraTx AllegraEra where
  type Tx AllegraEra = ShelleyTx AllegraEra

  mkBasicTx :: TxBody AllegraEra -> Tx AllegraEra
mkBasicTx = TxBody AllegraEra -> Tx AllegraEra
TxBody AllegraEra -> ShelleyTx AllegraEra
forall era. EraTx era => TxBody era -> ShelleyTx era
mkBasicShelleyTx

  bodyTxL :: Lens' (Tx AllegraEra) (TxBody AllegraEra)
bodyTxL = (TxBody AllegraEra -> f (TxBody AllegraEra))
-> Tx AllegraEra -> f (Tx AllegraEra)
(TxBody AllegraEra -> f (TxBody AllegraEra))
-> ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra)
forall era. EraTx era => Lens' (ShelleyTx era) (TxBody era)
Lens' (ShelleyTx AllegraEra) (TxBody AllegraEra)
bodyShelleyTxL
  {-# INLINE bodyTxL #-}

  witsTxL :: Lens' (Tx AllegraEra) (TxWits AllegraEra)
witsTxL = (TxWits AllegraEra -> f (TxWits AllegraEra))
-> Tx AllegraEra -> f (Tx AllegraEra)
(TxWits AllegraEra -> f (TxWits AllegraEra))
-> ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra)
forall era. EraTx era => Lens' (ShelleyTx era) (TxWits era)
Lens' (ShelleyTx AllegraEra) (TxWits AllegraEra)
witsShelleyTxL
  {-# INLINE witsTxL #-}

  auxDataTxL :: Lens' (Tx AllegraEra) (StrictMaybe (TxAuxData AllegraEra))
auxDataTxL = (StrictMaybe (TxAuxData AllegraEra)
 -> f (StrictMaybe (TxAuxData AllegraEra)))
-> Tx AllegraEra -> f (Tx AllegraEra)
(StrictMaybe (TxAuxData AllegraEra)
 -> f (StrictMaybe (TxAuxData AllegraEra)))
-> ShelleyTx AllegraEra -> f (ShelleyTx AllegraEra)
forall era.
EraTx era =>
Lens' (ShelleyTx era) (StrictMaybe (TxAuxData era))
Lens' (ShelleyTx AllegraEra) (StrictMaybe (TxAuxData AllegraEra))
auxDataShelleyTxL
  {-# INLINE auxDataTxL #-}

  sizeTxF :: SimpleGetter (Tx AllegraEra) Integer
sizeTxF = (Integer -> Const r Integer)
-> Tx AllegraEra -> Const r (Tx AllegraEra)
Getting r (ShelleyTx AllegraEra) Integer
forall era r. Getting r (ShelleyTx era) Integer
sizeShelleyTxF
  {-# INLINE sizeTxF #-}

  wireSizeTxF :: SimpleGetter (Tx AllegraEra) Word32
wireSizeTxF = (Word32 -> Const r Word32)
-> Tx AllegraEra -> Const r (Tx AllegraEra)
Getting r (ShelleyTx AllegraEra) Word32
forall era r. Getting r (ShelleyTx era) Word32
wireSizeShelleyTxF
  {-# INLINE wireSizeTxF #-}

  validateNativeScript :: Tx AllegraEra -> NativeScript AllegraEra -> Bool
validateNativeScript = Tx AllegraEra -> NativeScript AllegraEra -> Bool
forall era.
(EraTx era, AllegraEraTxBody era, AllegraEraScript 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

  upgradeTx :: EraTx (PreviousEra AllegraEra) =>
Tx (PreviousEra AllegraEra)
-> Either (TxUpgradeError AllegraEra) (Tx AllegraEra)
upgradeTx (ShelleyTx TxBody ShelleyEra
txb TxWits ShelleyEra
txwits StrictMaybe (TxAuxData ShelleyEra)
txAux) =
    TxBody AllegraEra
-> TxWits AllegraEra
-> StrictMaybe (TxAuxData AllegraEra)
-> ShelleyTx AllegraEra
TxBody AllegraEra
-> ShelleyTxWits AllegraEra
-> StrictMaybe (AllegraTxAuxData AllegraEra)
-> ShelleyTx AllegraEra
forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
      (TxBody AllegraEra
 -> ShelleyTxWits AllegraEra
 -> StrictMaybe (AllegraTxAuxData AllegraEra)
 -> ShelleyTx AllegraEra)
-> Either Void (TxBody AllegraEra)
-> Either
     Void
     (ShelleyTxWits AllegraEra
      -> StrictMaybe (AllegraTxAuxData AllegraEra)
      -> ShelleyTx AllegraEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxBody (PreviousEra AllegraEra)
-> Either (TxBodyUpgradeError AllegraEra) (TxBody AllegraEra)
forall era.
(EraTxBody era, EraTxBody (PreviousEra era)) =>
TxBody (PreviousEra era)
-> Either (TxBodyUpgradeError era) (TxBody era)
upgradeTxBody TxBody (PreviousEra AllegraEra)
TxBody ShelleyEra
txb
      Either
  Void
  (ShelleyTxWits AllegraEra
   -> StrictMaybe (AllegraTxAuxData AllegraEra)
   -> ShelleyTx AllegraEra)
-> Either Void (ShelleyTxWits AllegraEra)
-> Either
     Void
     (StrictMaybe (AllegraTxAuxData AllegraEra) -> ShelleyTx AllegraEra)
forall a b. Either Void (a -> b) -> Either Void a -> Either Void b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ShelleyTxWits AllegraEra -> Either Void (ShelleyTxWits AllegraEra)
forall a. a -> Either Void a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxWits (PreviousEra AllegraEra) -> TxWits AllegraEra
forall era.
(EraTxWits era, EraTxWits (PreviousEra era)) =>
TxWits (PreviousEra era) -> TxWits era
upgradeTxWits TxWits (PreviousEra AllegraEra)
TxWits ShelleyEra
txwits)
      Either
  Void
  (StrictMaybe (AllegraTxAuxData AllegraEra) -> ShelleyTx AllegraEra)
-> Either Void (StrictMaybe (AllegraTxAuxData AllegraEra))
-> Either Void (ShelleyTx AllegraEra)
forall a b. Either Void (a -> b) -> Either Void a -> Either Void b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> StrictMaybe (AllegraTxAuxData AllegraEra)
-> Either Void (StrictMaybe (AllegraTxAuxData AllegraEra))
forall a. a -> Either Void a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((TxAuxData (PreviousEra AllegraEra) -> AllegraTxAuxData AllegraEra)
-> StrictMaybe (TxAuxData (PreviousEra AllegraEra))
-> StrictMaybe (AllegraTxAuxData AllegraEra)
forall a b. (a -> b) -> StrictMaybe a -> StrictMaybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TxAuxData (PreviousEra AllegraEra) -> TxAuxData AllegraEra
TxAuxData (PreviousEra AllegraEra) -> AllegraTxAuxData AllegraEra
forall era.
(EraTxAuxData era, EraTxAuxData (PreviousEra era)) =>
TxAuxData (PreviousEra era) -> TxAuxData era
upgradeTxAuxData StrictMaybe (TxAuxData (PreviousEra AllegraEra))
StrictMaybe (TxAuxData ShelleyEra)
txAux)

-- =======================================================
-- 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) => Tx era -> NativeScript era -> Bool
validateTimelock :: forall era.
(EraTx era, AllegraEraTxBody era, AllegraEraScript era) =>
Tx era -> NativeScript era -> Bool
validateTimelock Tx era
tx NativeScript era
timelock = Set (KeyHash 'Witness)
-> ValidityInterval -> NativeScript era -> Bool
forall era.
AllegraEraScript 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 #-}