{-# 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.Crypto (Crypto, StandardCrypto)
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 Crypto c => EraTx (AllegraEra c) where
  {-# SPECIALIZE instance EraTx (AllegraEra StandardCrypto) #-}

  type Tx (AllegraEra c) = ShelleyTx (AllegraEra c)

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

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

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

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

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

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

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

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

  upgradeTx :: EraTx (PreviousEra (AllegraEra c)) =>
Tx (PreviousEra (AllegraEra c))
-> Either (TxUpgradeError (AllegraEra c)) (Tx (AllegraEra c))
upgradeTx (ShelleyTx TxBody (ShelleyEra c)
txb TxWits (ShelleyEra c)
txwits StrictMaybe (TxAuxData (ShelleyEra c))
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 c)
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 c)
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 c))
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 (EraCrypto era))
-> ValidityInterval -> NativeScript era -> Bool
evalTimelock Set (KeyHash 'Witness (EraCrypto era))
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 (EraCrypto era))
vhks = forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall (kr :: KeyRole) c. WitVKey kr c -> KeyHash 'Witness c
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 (EraCrypto era)))
addrTxWitsL)
{-# INLINEABLE validateTimelock #-}