{-# 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 = forall era. EraTx era => TxBody era -> ShelleyTx era
mkBasicShelleyTx

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

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

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

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

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

  validateNativeScript :: Tx AllegraEra -> NativeScript AllegraEra -> Bool
validateNativeScript = 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
_ = 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) =
    forall era.
EraTx era =>
TxBody era
-> TxWits era -> StrictMaybe (TxAuxData era) -> ShelleyTx era
ShelleyTx
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(EraTxBody era, EraTxBody (PreviousEra era)) =>
TxBody (PreviousEra era)
-> Either (TxBodyUpgradeError era) (TxBody era)
upgradeTxBody TxBody ShelleyEra
txb
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall era.
(EraTxWits era, EraTxWits (PreviousEra era)) =>
TxWits (PreviousEra era) -> TxWits era
upgradeTxWits TxWits ShelleyEra
txwits)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall era.
(EraTxAuxData era, EraTxAuxData (PreviousEra era)) =>
TxAuxData (PreviousEra era) -> TxAuxData era
upgradeTxAuxData 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 = forall era.
AllegraEraScript era =>
Set (KeyHash 'Witness)
-> ValidityInterval -> NativeScript era -> Bool
evalTimelock Set (KeyHash 'Witness)
vhks (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
vldtTxBodyL) NativeScript era
timelock
  where
    vhks :: Set (KeyHash 'Witness)
vhks = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (kr :: KeyRole). WitVKey kr -> KeyHash 'Witness
witVKeyHash (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Set (WitVKey 'Witness))
addrTxWitsL)
{-# INLINEABLE validateTimelock #-}