{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# 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 (..), Timelock, evalTimelock)
import Cardano.Ledger.Allegra.TxAuxData ()
import Cardano.Ledger.Allegra.TxBody (AllegraEraTxBody (..))
import Cardano.Ledger.Allegra.TxWits ()
import Cardano.Ledger.Core (
  EraTx (..),
  EraTxWits (..),
  NativeScript,
 )
import Cardano.Ledger.Keys.WitVKey (witVKeyHash)
import Cardano.Ledger.Shelley.Tx (
  ShelleyTx (..),
  auxDataShelleyTxL,
  bodyShelleyTxL,
  mkBasicShelleyTx,
  shelleyMinFeeTx,
  sizeShelleyTxF,
  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 (f :: * -> *).
Functor f =>
(TxBody era -> f (TxBody era))
-> ShelleyTx era -> f (ShelleyTx era)
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 (f :: * -> *).
Functor f =>
(TxWits era -> f (TxWits era))
-> ShelleyTx era -> f (ShelleyTx era)
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 (f :: * -> *).
Functor f =>
(StrictMaybe (TxAuxData era) -> f (StrictMaybe (TxAuxData era)))
-> ShelleyTx era -> f (ShelleyTx era)
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. 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

-- =======================================================
-- 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 #-}