{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Cardano.Ledger.Alonzo.Plutus.Context (
LedgerTxInfo (..),
EraPlutusTxInfo (..),
EraPlutusContext (..),
toPlutusWithContext,
lookupTxInfoResultImpossible,
PlutusTxInfo,
PlutusTxCert,
PlutusScriptPurpose,
PlutusScriptContext,
)
where
import Cardano.Ledger.Alonzo.Scripts (
AlonzoEraScript,
AsIxItem (..),
PlutusPurpose,
PlutusScript (..),
hoistPlutusPurpose,
toAsItem,
)
import Cardano.Ledger.Alonzo.UTxO (AlonzoEraUTxO (getSpendingDatum))
import Cardano.Ledger.BaseTypes (ProtVer (..))
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Plutus (
CostModel,
Data,
ExUnits,
Language (..),
Plutus,
PlutusArgs,
PlutusLanguage,
PlutusRunnable,
PlutusScriptContext,
PlutusWithContext (..),
SLanguage (..),
isLanguage,
)
import Cardano.Ledger.State (UTxO (..))
import Cardano.Slotting.EpochInfo (EpochInfo)
import Cardano.Slotting.Time (SystemStart)
import Control.DeepSeq (NFData)
import Data.Aeson (ToJSON)
import Data.Kind (Type)
import Data.Text (Text)
import GHC.Stack
import NoThunks.Class (NoThunks)
import qualified PlutusLedgerApi.V1 as PV1
import qualified PlutusLedgerApi.V2 as PV2
import qualified PlutusLedgerApi.V3 as PV3
data LedgerTxInfo era = LedgerTxInfo
{ forall era. LedgerTxInfo era -> ProtVer
ltiProtVer :: !ProtVer
, forall era. LedgerTxInfo era -> EpochInfo (Either Text)
ltiEpochInfo :: !(EpochInfo (Either Text))
, forall era. LedgerTxInfo era -> SystemStart
ltiSystemStart :: !SystemStart
, forall era. LedgerTxInfo era -> UTxO era
ltiUTxO :: !(UTxO era)
, forall era. LedgerTxInfo era -> Tx era
ltiTx :: !(Tx era)
}
class (PlutusLanguage l, EraPlutusContext era) => EraPlutusTxInfo (l :: Language) era where
toPlutusTxCert ::
proxy l ->
ProtVer ->
TxCert era ->
Either (ContextError era) (PlutusTxCert l)
toPlutusScriptPurpose ::
proxy l ->
ProtVer ->
PlutusPurpose AsIxItem era ->
Either (ContextError era) (PlutusScriptPurpose l)
toPlutusTxInfo ::
proxy l ->
LedgerTxInfo era ->
Either (ContextError era) (PlutusTxInfo l)
toPlutusArgs ::
proxy l ->
ProtVer ->
PlutusTxInfo l ->
PlutusPurpose AsIxItem era ->
Maybe (Data era) ->
Data era ->
Either (ContextError era) (PlutusArgs l)
class
( AlonzoEraScript era
, Eq (ContextError era)
, Show (ContextError era)
, NFData (ContextError era)
, NoThunks (ContextError era)
, EncCBOR (ContextError era)
, DecCBOR (ContextError era)
, ToJSON (ContextError era)
) =>
EraPlutusContext era
where
type ContextError era = (r :: Type) | r -> era
data TxInfoResult era :: Type
mkTxInfoResult :: LedgerTxInfo era -> TxInfoResult era
lookupTxInfoResult ::
EraPlutusTxInfo l era =>
SLanguage l -> TxInfoResult era -> Either (ContextError era) (PlutusTxInfo l)
mkPlutusWithContext ::
PlutusScript era ->
ScriptHash ->
PlutusPurpose AsIxItem era ->
LedgerTxInfo era ->
TxInfoResult era ->
(Data era, ExUnits) ->
CostModel ->
Either (ContextError era) PlutusWithContext
toPlutusWithContext ::
forall l era.
(EraPlutusTxInfo l era, AlonzoEraUTxO era) =>
Either (Plutus l) (PlutusRunnable l) ->
ScriptHash ->
PlutusPurpose AsIxItem era ->
LedgerTxInfo era ->
TxInfoResult era ->
(Data era, ExUnits) ->
CostModel ->
Either (ContextError era) PlutusWithContext
toPlutusWithContext :: forall (l :: Language) era.
(EraPlutusTxInfo l era, AlonzoEraUTxO era) =>
Either (Plutus l) (PlutusRunnable l)
-> ScriptHash
-> PlutusPurpose AsIxItem era
-> LedgerTxInfo era
-> TxInfoResult era
-> (Data era, ExUnits)
-> CostModel
-> Either (ContextError era) PlutusWithContext
toPlutusWithContext Either (Plutus l) (PlutusRunnable l)
script ScriptHash
scriptHash PlutusPurpose AsIxItem era
plutusPurpose LedgerTxInfo era
lti TxInfoResult era
txInfoResult (Data era
redeemerData, ExUnits
exUnits) CostModel
costModel = do
let slang :: SLanguage l
slang = forall (l :: Language). PlutusLanguage l => SLanguage l
isLanguage @l
maybeSpendingDatum :: Maybe (Data era)
maybeSpendingDatum =
forall era.
AlonzoEraUTxO era =>
UTxO era -> Tx era -> PlutusPurpose AsItem era -> Maybe (Data era)
getSpendingDatum (forall era. LedgerTxInfo era -> UTxO era
ltiUTxO LedgerTxInfo era
lti) (forall era. LedgerTxInfo era -> Tx era
ltiTx LedgerTxInfo era
lti) (forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose forall ix it. AsIxItem ix it -> AsItem ix it
toAsItem PlutusPurpose AsIxItem era
plutusPurpose)
PlutusTxInfo l
txInfo <- forall era (l :: Language).
(EraPlutusContext era, EraPlutusTxInfo l era) =>
SLanguage l
-> TxInfoResult era -> Either (ContextError era) (PlutusTxInfo l)
lookupTxInfoResult SLanguage l
slang TxInfoResult era
txInfoResult
PlutusArgs l
plutusArgs <-
forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> ProtVer
-> PlutusTxInfo l
-> PlutusPurpose AsIxItem era
-> Maybe (Data era)
-> Data era
-> Either (ContextError era) (PlutusArgs l)
toPlutusArgs SLanguage l
slang (forall era. LedgerTxInfo era -> ProtVer
ltiProtVer LedgerTxInfo era
lti) PlutusTxInfo l
txInfo PlutusPurpose AsIxItem era
plutusPurpose Maybe (Data era)
maybeSpendingDatum Data era
redeemerData
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
PlutusWithContext
{ pwcProtocolVersion :: Version
pwcProtocolVersion = ProtVer -> Version
pvMajor (forall era. LedgerTxInfo era -> ProtVer
ltiProtVer LedgerTxInfo era
lti)
, pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcScript = Either (Plutus l) (PlutusRunnable l)
script
, pwcScriptHash :: ScriptHash
pwcScriptHash = ScriptHash
scriptHash
, pwcArgs :: PlutusArgs l
pwcArgs = PlutusArgs l
plutusArgs
, pwcExUnits :: ExUnits
pwcExUnits = ExUnits
exUnits
, pwcCostModel :: CostModel
pwcCostModel = CostModel
costModel
}
lookupTxInfoResultImpossible ::
(HasCallStack, EraPlutusTxInfo l era) => SLanguage l -> Either (ContextError era) (PlutusTxInfo l)
lookupTxInfoResultImpossible :: forall (l :: Language) era.
(HasCallStack, EraPlutusTxInfo l era) =>
SLanguage l -> Either (ContextError era) (PlutusTxInfo l)
lookupTxInfoResultImpossible SLanguage l
slang =
forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Impossible: Attempt to lookup TxInfoResult for an unsupported language: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show SLanguage l
slang
type family PlutusTxCert (l :: Language) where
PlutusTxCert 'PlutusV1 = PV1.DCert
PlutusTxCert 'PlutusV2 = PV2.DCert
PlutusTxCert 'PlutusV3 = PV3.TxCert
type family PlutusScriptPurpose (l :: Language) where
PlutusScriptPurpose 'PlutusV1 = PV1.ScriptPurpose
PlutusScriptPurpose 'PlutusV2 = PV2.ScriptPurpose
PlutusScriptPurpose 'PlutusV3 = PV3.ScriptPurpose
type family PlutusTxInfo (l :: Language) where
PlutusTxInfo 'PlutusV1 = PV1.TxInfo
PlutusTxInfo 'PlutusV2 = PV2.TxInfo
PlutusTxInfo 'PlutusV3 = PV3.TxInfo