{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Alonzo.Plutus.TxInfo (
  AlonzoContextError (..),
  TxOutSource (..),
  transLookupTxOut,
  transTxOut,
  transValidityInterval,
  transPolicyID,
  transAssetName,
  transMultiAsset,
  transMintValue,
  transValue,
  transWithdrawals,
  transDataPair,
  transTxCert,
  transTxCertCommon,
  transPlutusPurpose,
  transTxBodyId,
  transTxBodyCerts,
  transTxBodyWithdrawals,
  transTxBodyReqSignerHashes,
  transTxWitsDatums,

  -- * LgacyPlutusArgs helpers
  toPlutusV1Args,
  toLegacyPlutusArgs,
)
where

import Cardano.Crypto.Hash.Class (hashToBytes)
import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Era (AlonzoEra)
import Cardano.Ledger.Alonzo.Plutus.Context
import Cardano.Ledger.Alonzo.Scripts (AlonzoPlutusPurpose (..), PlutusScript (..), toAsItem)
import Cardano.Ledger.Alonzo.TxWits (unTxDats)
import Cardano.Ledger.BaseTypes (ProtVer, StrictMaybe (..), strictMaybeToMaybe)
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
import Cardano.Ledger.Binary.Coders (
  Decode (..),
  Encode (..),
  decode,
  encode,
  (!>),
  (<!),
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Mary.Value (
  AssetName (..),
  MaryValue (..),
  MultiAsset (..),
  PolicyID (..),
 )
import Cardano.Ledger.Plutus.Data (Data, getPlutusData)
import Cardano.Ledger.Plutus.Language (Language (..), LegacyPlutusArgs (..), PlutusArgs (..))
import Cardano.Ledger.Plutus.TxInfo
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Rules.ValidationMode (Inject (..))
import qualified Cardano.Ledger.Shelley.HardForks as HardForks
import Cardano.Ledger.TxIn (TxIn (..), txInToText)
import Cardano.Ledger.UTxO (UTxO (..))
import Cardano.Ledger.Val (zero)
import Cardano.Slotting.EpochInfo (EpochInfo)
import Cardano.Slotting.Time (SystemStart)
import Control.Arrow (left)
import Control.DeepSeq (NFData)
import Control.Monad (forM, guard)
import Data.Aeson (ToJSON (..), pattern String)
import Data.ByteString.Short as SBS (fromShort)
import Data.Foldable as F (Foldable (..))
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, isNothing, mapMaybe)
import qualified Data.Set as Set
import Data.Text (Text)
import GHC.Generics (Generic)
import Lens.Micro ((^.))
import NoThunks.Class (NoThunks)
import qualified PlutusLedgerApi.V1 as PV1

instance EraPlutusTxInfo 'PlutusV1 AlonzoEra where
  toPlutusTxCert :: forall (proxy :: Language -> *).
proxy 'PlutusV1
-> ProtVer
-> TxCert AlonzoEra
-> Either (ContextError AlonzoEra) (PlutusTxCert 'PlutusV1)
toPlutusTxCert proxy 'PlutusV1
_ ProtVer
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
TxCert era -> DCert
transTxCert

  toPlutusScriptPurpose :: forall (proxy :: Language -> *).
proxy 'PlutusV1
-> ProtVer
-> PlutusPurpose AsIxItem AlonzoEra
-> Either (ContextError AlonzoEra) (PlutusScriptPurpose 'PlutusV1)
toPlutusScriptPurpose proxy 'PlutusV1
proxy ProtVer
pv = forall (l :: Language) era (proxy :: Language -> *).
(EraPlutusTxInfo l era, PlutusTxCert l ~ DCert) =>
proxy l
-> ProtVer
-> AlonzoPlutusPurpose AsItem era
-> Either (ContextError era) ScriptPurpose
transPlutusPurpose proxy 'PlutusV1
proxy ProtVer
pv forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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

  toPlutusTxInfo :: forall (proxy :: Language -> *).
proxy 'PlutusV1
-> LedgerTxInfo AlonzoEra
-> Either (ContextError AlonzoEra) (PlutusTxInfo 'PlutusV1)
toPlutusTxInfo proxy 'PlutusV1
proxy LedgerTxInfo {ProtVer
ltiProtVer :: forall era. LedgerTxInfo era -> ProtVer
ltiProtVer :: ProtVer
ltiProtVer, EpochInfo (Either Text)
ltiEpochInfo :: forall era. LedgerTxInfo era -> EpochInfo (Either Text)
ltiEpochInfo :: EpochInfo (Either Text)
ltiEpochInfo, SystemStart
ltiSystemStart :: forall era. LedgerTxInfo era -> SystemStart
ltiSystemStart :: SystemStart
ltiSystemStart, UTxO AlonzoEra
ltiUTxO :: forall era. LedgerTxInfo era -> UTxO era
ltiUTxO :: UTxO AlonzoEra
ltiUTxO, Tx AlonzoEra
ltiTx :: forall era. LedgerTxInfo era -> Tx era
ltiTx :: Tx AlonzoEra
ltiTx} = do
    POSIXTimeRange
timeRange <-
      forall {k} (proxy :: k -> *) (era :: k) a.
Inject (AlonzoContextError era) a =>
proxy era
-> ProtVer
-> EpochInfo (Either Text)
-> SystemStart
-> ValidityInterval
-> Either a POSIXTimeRange
transValidityInterval Tx AlonzoEra
ltiTx ProtVer
ltiProtVer EpochInfo (Either Text)
ltiEpochInfo SystemStart
ltiSystemStart (TxBody AlonzoEra
txBody forall s a. s -> Getting a s a -> a
^. forall era.
AllegraEraTxBody era =>
Lens' (TxBody era) ValidityInterval
vldtTxBodyL)
    [Maybe TxInInfo]
txInsMaybes <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. Set a -> [a]
Set.toList (TxBody AlonzoEra
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL)) forall a b. (a -> b) -> a -> b
$ \TxIn
txIn -> do
      AlonzoTxOut AlonzoEra
txOut <- forall era a.
Inject (AlonzoContextError era) a =>
UTxO era -> TxIn -> Either a (TxOut era)
transLookupTxOut UTxO AlonzoEra
ltiUTxO TxIn
txIn
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TxOutRef -> TxOut -> TxInInfo
PV1.TxInInfo (TxIn -> TxOutRef
transTxIn TxIn
txIn) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
(Value era ~ MaryValue, AlonzoEraTxOut era) =>
TxOut era -> Maybe TxOut
transTxOut AlonzoTxOut AlonzoEra
txOut
    [DCert]
txCerts <- forall (l :: Language) era (proxy :: Language -> *).
(EraPlutusTxInfo l era, EraTxBody era) =>
proxy l
-> ProtVer
-> TxBody era
-> Either (ContextError era) [PlutusTxCert l]
transTxBodyCerts proxy 'PlutusV1
proxy ProtVer
ltiProtVer TxBody AlonzoEra
txBody
    forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
      PV1.TxInfo
        { -- A mistake was made in Alonzo of filtering out Byron addresses, so we need to
          -- preserve this behavior by only retaining the Just case:
          txInfoInputs :: [TxInInfo]
PV1.txInfoInputs = forall a. [Maybe a] -> [a]
catMaybes [Maybe TxInInfo]
txInsMaybes
        , txInfoOutputs :: [TxOut]
PV1.txInfoOutputs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall era.
(Value era ~ MaryValue, AlonzoEraTxOut era) =>
TxOut era -> Maybe TxOut
transTxOut forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (TxBody AlonzoEra
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL)
        , txInfoFee :: Value
PV1.txInfoFee = Coin -> Value
transCoinToValue (TxBody AlonzoEra
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL)
        , txInfoMint :: Value
PV1.txInfoMint = MultiAsset -> Value
transMintValue (TxBody AlonzoEra
txBody forall s a. s -> Getting a s a -> a
^. forall era. MaryEraTxBody era => Lens' (TxBody era) MultiAsset
mintTxBodyL)
        , txInfoDCert :: [DCert]
PV1.txInfoDCert = [DCert]
txCerts
        , txInfoWdrl :: [(StakingCredential, Integer)]
PV1.txInfoWdrl = forall era.
EraTxBody era =>
TxBody era -> [(StakingCredential, Integer)]
transTxBodyWithdrawals TxBody AlonzoEra
txBody
        , txInfoValidRange :: POSIXTimeRange
PV1.txInfoValidRange = POSIXTimeRange
timeRange
        , txInfoSignatories :: [PubKeyHash]
PV1.txInfoSignatories = forall era. AlonzoEraTxBody era => TxBody era -> [PubKeyHash]
transTxBodyReqSignerHashes TxBody AlonzoEra
txBody
        , txInfoData :: [(DatumHash, Datum)]
PV1.txInfoData = forall era.
AlonzoEraTxWits era =>
TxWits era -> [(DatumHash, Datum)]
transTxWitsDatums (Tx AlonzoEra
ltiTx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL)
        , txInfoId :: TxId
PV1.txInfoId = forall era. EraTxBody era => TxBody era -> TxId
transTxBodyId TxBody AlonzoEra
txBody
        }
    where
      txBody :: TxBody AlonzoEra
txBody = Tx AlonzoEra
ltiTx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL

  toPlutusArgs :: forall (proxy :: Language -> *).
proxy 'PlutusV1
-> ProtVer
-> PlutusTxInfo 'PlutusV1
-> PlutusPurpose AsIxItem AlonzoEra
-> Maybe (Data AlonzoEra)
-> Data AlonzoEra
-> Either (ContextError AlonzoEra) (PlutusArgs 'PlutusV1)
toPlutusArgs = forall era (proxy :: Language -> *).
EraPlutusTxInfo 'PlutusV1 era =>
proxy 'PlutusV1
-> ProtVer
-> TxInfo
-> PlutusPurpose AsIxItem era
-> Maybe (Data era)
-> Data era
-> Either (ContextError era) (PlutusArgs 'PlutusV1)
toPlutusV1Args

toPlutusV1Args ::
  EraPlutusTxInfo 'PlutusV1 era =>
  proxy 'PlutusV1 ->
  ProtVer ->
  PV1.TxInfo ->
  PlutusPurpose AsIxItem era ->
  Maybe (Data era) ->
  Data era ->
  Either (ContextError era) (PlutusArgs 'PlutusV1)
toPlutusV1Args :: forall era (proxy :: Language -> *).
EraPlutusTxInfo 'PlutusV1 era =>
proxy 'PlutusV1
-> ProtVer
-> TxInfo
-> PlutusPurpose AsIxItem era
-> Maybe (Data era)
-> Data era
-> Either (ContextError era) (PlutusArgs 'PlutusV1)
toPlutusV1Args proxy 'PlutusV1
proxy ProtVer
pv TxInfo
txInfo PlutusPurpose AsIxItem era
scriptPurpose Maybe (Data era)
maybeSpendingData Data era
redeemerData =
  LegacyPlutusArgs 'PlutusV1 -> PlutusArgs 'PlutusV1
PlutusV1Args
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> ProtVer
-> (PlutusScriptPurpose l -> PlutusScriptContext l)
-> PlutusPurpose AsIxItem era
-> Maybe (Data era)
-> Data era
-> Either (ContextError era) (LegacyPlutusArgs l)
toLegacyPlutusArgs proxy 'PlutusV1
proxy ProtVer
pv (TxInfo -> ScriptPurpose -> ScriptContext
PV1.ScriptContext TxInfo
txInfo) PlutusPurpose AsIxItem era
scriptPurpose Maybe (Data era)
maybeSpendingData Data era
redeemerData

toLegacyPlutusArgs ::
  EraPlutusTxInfo l era =>
  proxy l ->
  ProtVer ->
  (PlutusScriptPurpose l -> PlutusScriptContext l) ->
  PlutusPurpose AsIxItem era ->
  Maybe (Data era) ->
  Data era ->
  Either (ContextError era) (LegacyPlutusArgs l)
toLegacyPlutusArgs :: forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> ProtVer
-> (PlutusScriptPurpose l -> PlutusScriptContext l)
-> PlutusPurpose AsIxItem era
-> Maybe (Data era)
-> Data era
-> Either (ContextError era) (LegacyPlutusArgs l)
toLegacyPlutusArgs proxy l
proxy ProtVer
pv PlutusScriptPurpose l -> PlutusScriptContext l
mkScriptContext PlutusPurpose AsIxItem era
scriptPurpose Maybe (Data era)
maybeSpendingData Data era
redeemerData = do
  PlutusScriptContext l
scriptContext <- PlutusScriptPurpose l -> PlutusScriptContext l
mkScriptContext forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> ProtVer
-> PlutusPurpose AsIxItem era
-> Either (ContextError era) (PlutusScriptPurpose l)
toPlutusScriptPurpose proxy l
proxy ProtVer
pv PlutusPurpose AsIxItem era
scriptPurpose
  let redeemer :: Data
redeemer = forall era. Data era -> Data
getPlutusData Data era
redeemerData
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Maybe (Data era)
maybeSpendingData of
    Maybe (Data era)
Nothing -> forall (l :: Language).
Data -> PlutusScriptContext l -> LegacyPlutusArgs l
LegacyPlutusArgs2 Data
redeemer PlutusScriptContext l
scriptContext
    Just Data era
spendingData -> forall (l :: Language).
Data -> Data -> PlutusScriptContext l -> LegacyPlutusArgs l
LegacyPlutusArgs3 (forall era. Data era -> Data
getPlutusData Data era
spendingData) Data
redeemer PlutusScriptContext l
scriptContext

instance EraPlutusContext AlonzoEra where
  type ContextError AlonzoEra = AlonzoContextError AlonzoEra

  mkPlutusWithContext :: PlutusScript AlonzoEra
-> ScriptHash
-> PlutusPurpose AsIxItem AlonzoEra
-> LedgerTxInfo AlonzoEra
-> (Data AlonzoEra, ExUnits)
-> CostModel
-> Either (ContextError AlonzoEra) PlutusWithContext
mkPlutusWithContext (AlonzoPlutusV1 Plutus 'PlutusV1
p) = forall (l :: Language) era.
(EraPlutusTxInfo l era, AlonzoEraUTxO era) =>
Either (Plutus l) (PlutusRunnable l)
-> ScriptHash
-> PlutusPurpose AsIxItem era
-> LedgerTxInfo era
-> (Data era, ExUnits)
-> CostModel
-> Either (ContextError era) PlutusWithContext
toPlutusWithContext (forall a b. a -> Either a b
Left Plutus 'PlutusV1
p)

data AlonzoContextError era
  = TranslationLogicMissingInput !TxIn
  | TimeTranslationPastHorizon !Text
  deriving (AlonzoContextError era -> AlonzoContextError era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (era :: k).
AlonzoContextError era -> AlonzoContextError era -> Bool
/= :: AlonzoContextError era -> AlonzoContextError era -> Bool
$c/= :: forall k (era :: k).
AlonzoContextError era -> AlonzoContextError era -> Bool
== :: AlonzoContextError era -> AlonzoContextError era -> Bool
$c== :: forall k (era :: k).
AlonzoContextError era -> AlonzoContextError era -> Bool
Eq, Int -> AlonzoContextError era -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (era :: k). Int -> AlonzoContextError era -> ShowS
forall k (era :: k). [AlonzoContextError era] -> ShowS
forall k (era :: k). AlonzoContextError era -> String
showList :: [AlonzoContextError era] -> ShowS
$cshowList :: forall k (era :: k). [AlonzoContextError era] -> ShowS
show :: AlonzoContextError era -> String
$cshow :: forall k (era :: k). AlonzoContextError era -> String
showsPrec :: Int -> AlonzoContextError era -> ShowS
$cshowsPrec :: forall k (era :: k). Int -> AlonzoContextError era -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (era :: k) x.
Rep (AlonzoContextError era) x -> AlonzoContextError era
forall k (era :: k) x.
AlonzoContextError era -> Rep (AlonzoContextError era) x
$cto :: forall k (era :: k) x.
Rep (AlonzoContextError era) x -> AlonzoContextError era
$cfrom :: forall k (era :: k) x.
AlonzoContextError era -> Rep (AlonzoContextError era) x
Generic)

instance NoThunks (AlonzoContextError era)

instance Era era => NFData (AlonzoContextError era)

instance Era era => EncCBOR (AlonzoContextError era) where
  encCBOR :: AlonzoContextError era -> Encoding
encCBOR = \case
    TranslationLogicMissingInput TxIn
txIn ->
      forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$ forall t. t -> Word -> Encode 'Open t
Sum (forall {k} (era :: k). TxIn -> AlonzoContextError era
TranslationLogicMissingInput @era) Word
1 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To TxIn
txIn
    TimeTranslationPastHorizon Text
err ->
      forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$ forall t. t -> Word -> Encode 'Open t
Sum (forall {k} (era :: k). Text -> AlonzoContextError era
TimeTranslationPastHorizon @era) Word
7 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Text
err

instance Era era => DecCBOR (AlonzoContextError era) where
  decCBOR :: forall s. Decoder s (AlonzoContextError era)
decCBOR = forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode forall a b. (a -> b) -> a -> b
$ forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"ContextError" forall a b. (a -> b) -> a -> b
$ \case
    Word
1 -> forall t. t -> Decode 'Open t
SumD (forall {k} (era :: k). TxIn -> AlonzoContextError era
TranslationLogicMissingInput @era) forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
7 -> forall t. t -> Decode 'Open t
SumD (forall {k} (era :: k). Text -> AlonzoContextError era
TimeTranslationPastHorizon @era) forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
n -> forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

instance ToJSON (AlonzoContextError era) where
  toJSON :: AlonzoContextError era -> Value
toJSON = \case
    TranslationLogicMissingInput TxIn
txin ->
      Text -> Value
String forall a b. (a -> b) -> a -> b
$ Text
"Transaction input does not exist in the UTxO: " forall a. Semigroup a => a -> a -> a
<> TxIn -> Text
txInToText TxIn
txin
    TimeTranslationPastHorizon Text
msg ->
      Text -> Value
String forall a b. (a -> b) -> a -> b
$ Text
"Time translation requested past the horizon: " forall a. Semigroup a => a -> a -> a
<> Text
msg

transLookupTxOut ::
  forall era a.
  Inject (AlonzoContextError era) a =>
  UTxO era ->
  TxIn ->
  Either a (TxOut era)
transLookupTxOut :: forall era a.
Inject (AlonzoContextError era) a =>
UTxO era -> TxIn -> Either a (TxOut era)
transLookupTxOut (UTxO Map TxIn (TxOut era)
utxo) TxIn
txIn =
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
txIn Map TxIn (TxOut era)
utxo of
    Maybe (TxOut era)
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall t s. Inject t s => t -> s
inject forall a b. (a -> b) -> a -> b
$ forall {k} (era :: k). TxIn -> AlonzoContextError era
TranslationLogicMissingInput @era TxIn
txIn
    Just TxOut era
txOut -> forall a b. b -> Either a b
Right TxOut era
txOut

-- | Translate a validity interval to POSIX time
transValidityInterval ::
  forall proxy era a.
  Inject (AlonzoContextError era) a =>
  proxy era ->
  ProtVer ->
  EpochInfo (Either Text) ->
  SystemStart ->
  ValidityInterval ->
  Either a PV1.POSIXTimeRange
transValidityInterval :: forall {k} (proxy :: k -> *) (era :: k) a.
Inject (AlonzoContextError era) a =>
proxy era
-> ProtVer
-> EpochInfo (Either Text)
-> SystemStart
-> ValidityInterval
-> Either a POSIXTimeRange
transValidityInterval proxy era
_ ProtVer
protVer EpochInfo (Either Text)
epochInfo SystemStart
systemStart = \case
  ValidityInterval StrictMaybe SlotNo
SNothing StrictMaybe SlotNo
SNothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Interval a
PV1.always
  ValidityInterval (SJust SlotNo
i) StrictMaybe SlotNo
SNothing -> forall a. a -> Interval a
PV1.from forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotNo -> Either a POSIXTime
transSlotToPOSIXTime SlotNo
i
  ValidityInterval StrictMaybe SlotNo
SNothing (SJust SlotNo
i) -> do
    POSIXTime
t <- SlotNo -> Either a POSIXTime
transSlotToPOSIXTime SlotNo
i
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      if ProtVer -> Bool
HardForks.translateUpperBoundForPlutusScripts ProtVer
protVer
        then
          forall a. LowerBound a -> UpperBound a -> Interval a
PV1.Interval
            (forall a. Extended a -> Bool -> LowerBound a
PV1.LowerBound forall a. Extended a
PV1.NegInf Bool
True)
            (forall a. a -> UpperBound a
PV1.strictUpperBound POSIXTime
t)
        else forall a. a -> Interval a
PV1.to POSIXTime
t
  ValidityInterval (SJust SlotNo
i) (SJust SlotNo
j) -> do
    POSIXTime
t1 <- SlotNo -> Either a POSIXTime
transSlotToPOSIXTime SlotNo
i
    POSIXTime
t2 <- SlotNo -> Either a POSIXTime
transSlotToPOSIXTime SlotNo
j
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
      forall a. LowerBound a -> UpperBound a -> Interval a
PV1.Interval
        (forall a. a -> LowerBound a
PV1.lowerBound POSIXTime
t1)
        (forall a. a -> UpperBound a
PV1.strictUpperBound POSIXTime
t2)
  where
    transSlotToPOSIXTime :: SlotNo -> Either a POSIXTime
transSlotToPOSIXTime =
      forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (forall t s. Inject t s => t -> s
inject forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (era :: k). Text -> AlonzoContextError era
TimeTranslationPastHorizon @era)
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. EpochInfo (Either Text)
-> SystemStart -> SlotNo -> Either Text POSIXTime
slotToPOSIXTime EpochInfo (Either Text)
epochInfo SystemStart
systemStart

-- | Translate a TxOut. Returns `Nothing` if a Byron address is present in the TxOut.
transTxOut ::
  (Value era ~ MaryValue, AlonzoEraTxOut era) => TxOut era -> Maybe PV1.TxOut
transTxOut :: forall era.
(Value era ~ MaryValue, AlonzoEraTxOut era) =>
TxOut era -> Maybe TxOut
transTxOut TxOut era
txOut = do
  -- Minor optimization:
  -- We can check for Byron address without decompacting the address in the TxOut
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> Bool
isNothing (TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
SimpleGetter (TxOut era) (Maybe BootstrapAddress)
bootAddrTxOutF)
  let val :: MaryValue
val = TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) (Value era)
valueTxOutL
      dataHash :: StrictMaybe DataHash
dataHash = TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe DataHash)
dataHashTxOutL
  Address
address <- Addr -> Maybe Address
transAddr (TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. EraTxOut era => Lens' (TxOut era) Addr
addrTxOutL)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Address -> Value -> Maybe DatumHash -> TxOut
PV1.TxOut Address
address (MaryValue -> Value
transValue MaryValue
val) (DataHash -> DatumHash
transDataHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe StrictMaybe DataHash
dataHash)

transTxBodyId :: EraTxBody era => TxBody era -> PV1.TxId
transTxBodyId :: forall era. EraTxBody era => TxBody era -> TxId
transTxBodyId TxBody era
txBody = BuiltinByteString -> TxId
PV1.TxId (forall i. SafeHash i -> BuiltinByteString
transSafeHash (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBody))

-- | Translate all `TxCert`s from within a `TxBody`
transTxBodyCerts ::
  (EraPlutusTxInfo l era, EraTxBody era) =>
  proxy l ->
  ProtVer ->
  TxBody era ->
  Either (ContextError era) [PlutusTxCert l]
transTxBodyCerts :: forall (l :: Language) era (proxy :: Language -> *).
(EraPlutusTxInfo l era, EraTxBody era) =>
proxy l
-> ProtVer
-> TxBody era
-> Either (ContextError era) [PlutusTxCert l]
transTxBodyCerts proxy l
proxy ProtVer
pv TxBody era
txBody =
  forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> ProtVer
-> TxCert era
-> Either (ContextError era) (PlutusTxCert l)
toPlutusTxCert proxy l
proxy ProtVer
pv) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL)

transWithdrawals :: Withdrawals -> Map.Map PV1.StakingCredential Integer
transWithdrawals :: Withdrawals -> Map StakingCredential Integer
transWithdrawals (Withdrawals Map RewardAccount Coin
mp) = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Map StakingCredential Integer
-> RewardAccount -> Coin -> Map StakingCredential Integer
accum forall k a. Map k a
Map.empty Map RewardAccount Coin
mp
  where
    accum :: Map StakingCredential Integer
-> RewardAccount -> Coin -> Map StakingCredential Integer
accum Map StakingCredential Integer
ans RewardAccount
rewardAccount (Coin Integer
n) =
      forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Credential -> StakingCredential
PV1.StakingHash (RewardAccount -> Credential
transRewardAccount RewardAccount
rewardAccount)) Integer
n Map StakingCredential Integer
ans

-- | Translate all `Withdrawal`s from within a `TxBody`
transTxBodyWithdrawals :: EraTxBody era => TxBody era -> [(PV1.StakingCredential, Integer)]
transTxBodyWithdrawals :: forall era.
EraTxBody era =>
TxBody era -> [(StakingCredential, Integer)]
transTxBodyWithdrawals TxBody era
txBody = forall k a. Map k a -> [(k, a)]
Map.toList (Withdrawals -> Map StakingCredential Integer
transWithdrawals (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
withdrawalsTxBodyL))

-- | Translate all required signers produced by `reqSignerHashesTxBodyL`s from within a
-- `TxBody`
transTxBodyReqSignerHashes :: AlonzoEraTxBody era => TxBody era -> [PV1.PubKeyHash]
transTxBodyReqSignerHashes :: forall era. AlonzoEraTxBody era => TxBody era -> [PubKeyHash]
transTxBodyReqSignerHashes TxBody era
txBody = forall (d :: KeyRole). KeyHash d -> PubKeyHash
transKeyHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (KeyHash 'Witness))
reqSignerHashesTxBodyL)

-- | Translate all `TxDats`s from within `TxWits`
transTxWitsDatums :: AlonzoEraTxWits era => TxWits era -> [(PV1.DatumHash, PV1.Datum)]
transTxWitsDatums :: forall era.
AlonzoEraTxWits era =>
TxWits era -> [(DatumHash, Datum)]
transTxWitsDatums TxWits era
txWits = forall era. (DataHash, Data era) -> (DatumHash, Datum)
transDataPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. Map k a -> [(k, a)]
Map.toList (forall era. TxDats era -> Map DataHash (Data era)
unTxDats forall a b. (a -> b) -> a -> b
$ TxWits era
txWits forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTxWits era => Lens' (TxWits era) (TxDats era)
datsTxWitsL)

-- ==================================
-- translate Values

transPolicyID :: PolicyID -> PV1.CurrencySymbol
transPolicyID :: PolicyID -> CurrencySymbol
transPolicyID (PolicyID (ScriptHash Hash ADDRHASH EraIndependentScript
x)) = BuiltinByteString -> CurrencySymbol
PV1.CurrencySymbol (forall a. HasToBuiltin a => a -> ToBuiltin a
PV1.toBuiltin (forall h a. Hash h a -> ByteString
hashToBytes Hash ADDRHASH EraIndependentScript
x))

transAssetName :: AssetName -> PV1.TokenName
transAssetName :: AssetName -> TokenName
transAssetName (AssetName ShortByteString
bs) = BuiltinByteString -> TokenName
PV1.TokenName (forall a. HasToBuiltin a => a -> ToBuiltin a
PV1.toBuiltin (ShortByteString -> ByteString
SBS.fromShort ShortByteString
bs))

transMultiAsset :: MultiAsset -> PV1.Value
transMultiAsset :: MultiAsset -> Value
transMultiAsset MultiAsset
ma = MultiAsset -> Value -> Value
transMultiAssetInternal MultiAsset
ma forall a. Monoid a => a
mempty

transMultiAssetInternal :: MultiAsset -> PV1.Value -> PV1.Value
transMultiAssetInternal :: MultiAsset -> Value -> Value
transMultiAssetInternal (MultiAsset Map PolicyID (Map AssetName Integer)
m) Value
initAcc = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Value -> PolicyID -> Map AssetName Integer -> Value
accum1 Value
initAcc Map PolicyID (Map AssetName Integer)
m
  where
    accum1 :: Value -> PolicyID -> Map AssetName Integer -> Value
accum1 Value
ans PolicyID
sym Map AssetName Integer
mp2 = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' Value -> AssetName -> Integer -> Value
accum2 Value
ans Map AssetName Integer
mp2
      where
        accum2 :: Value -> AssetName -> Integer -> Value
accum2 Value
ans2 AssetName
tok Integer
quantity =
          (Integer -> Integer -> Integer) -> Value -> Value -> Value
PV1.unionWith
            forall a. Num a => a -> a -> a
(+)
            Value
ans2
            (CurrencySymbol -> TokenName -> Integer -> Value
PV1.singleton (PolicyID -> CurrencySymbol
transPolicyID PolicyID
sym) (AssetName -> TokenName
transAssetName AssetName
tok) Integer
quantity)

-- | Hysterical raisins:
--
-- Previously transaction body contained a mint field with MaryValue instead of a
-- MultiAsset, which has changed since then to just MultiAsset (because minting ADA
-- makes no sense). However, if we don't preserve previous translation, scripts that
-- previously succeeded will fail.
transMintValue :: MultiAsset -> PV1.Value
transMintValue :: MultiAsset -> Value
transMintValue MultiAsset
m = MultiAsset -> Value -> Value
transMultiAssetInternal MultiAsset
m (Coin -> Value
transCoinToValue forall t. Val t => t
zero)

transValue :: MaryValue -> PV1.Value
transValue :: MaryValue -> Value
transValue (MaryValue Coin
c MultiAsset
m) = Coin -> Value
transCoinToValue Coin
c forall a. Semigroup a => a -> a -> a
<> MultiAsset -> Value
transMultiAsset MultiAsset
m

-- =============================================
-- translate fields like TxCert, Withdrawals, and similar

transTxCert :: (ShelleyEraTxCert era, ProtVerAtMost era 8) => TxCert era -> PV1.DCert
transTxCert :: forall era.
(ShelleyEraTxCert era, ProtVerAtMost era 8) =>
TxCert era -> DCert
transTxCert TxCert era
txCert =
  case forall era. ShelleyEraTxCert era => TxCert era -> Maybe DCert
transTxCertCommon TxCert era
txCert of
    Just DCert
cert -> DCert
cert
    Maybe DCert
Nothing ->
      case TxCert era
txCert of
        GenesisDelegTxCert {} -> DCert
PV1.DCertGenesis
        MirTxCert {} -> DCert
PV1.DCertMir
        TxCert era
_ -> forall a. HasCallStack => String -> a
error String
"Impossible: All certificates should have been accounted for"

-- | Just like `transTxCert`, but do not translate certificates that were deprecated in Conway
transTxCertCommon :: ShelleyEraTxCert era => TxCert era -> Maybe PV1.DCert
transTxCertCommon :: forall era. ShelleyEraTxCert era => TxCert era -> Maybe DCert
transTxCertCommon = \case
  RegTxCert StakeCredential
stakeCred ->
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ StakingCredential -> DCert
PV1.DCertDelegRegKey (Credential -> StakingCredential
PV1.StakingHash (forall (kr :: KeyRole). Credential kr -> Credential
transCred StakeCredential
stakeCred))
  UnRegTxCert StakeCredential
stakeCred ->
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ StakingCredential -> DCert
PV1.DCertDelegDeRegKey (Credential -> StakingCredential
PV1.StakingHash (forall (kr :: KeyRole). Credential kr -> Credential
transCred StakeCredential
stakeCred))
  DelegStakeTxCert StakeCredential
stakeCred KeyHash 'StakePool
keyHash ->
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ StakingCredential -> PubKeyHash -> DCert
PV1.DCertDelegDelegate (Credential -> StakingCredential
PV1.StakingHash (forall (kr :: KeyRole). Credential kr -> Credential
transCred StakeCredential
stakeCred)) (forall (d :: KeyRole). KeyHash d -> PubKeyHash
transKeyHash KeyHash 'StakePool
keyHash)
  RegPoolTxCert (PoolParams {KeyHash 'StakePool
ppId :: PoolParams -> KeyHash 'StakePool
ppId :: KeyHash 'StakePool
ppId, VRFVerKeyHash 'StakePoolVRF
ppVrf :: PoolParams -> VRFVerKeyHash 'StakePoolVRF
ppVrf :: VRFVerKeyHash 'StakePoolVRF
ppVrf}) ->
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
      PubKeyHash -> PubKeyHash -> DCert
PV1.DCertPoolRegister
        (forall (d :: KeyRole). KeyHash d -> PubKeyHash
transKeyHash KeyHash 'StakePool
ppId)
        (BuiltinByteString -> PubKeyHash
PV1.PubKeyHash (forall a. HasToBuiltin a => a -> ToBuiltin a
PV1.toBuiltin (forall h a. Hash h a -> ByteString
hashToBytes (forall (r :: KeyRoleVRF). VRFVerKeyHash r -> Hash HASH KeyRoleVRF
unVRFVerKeyHash VRFVerKeyHash 'StakePoolVRF
ppVrf))))
  RetirePoolTxCert KeyHash 'StakePool
poolId EpochNo
retireEpochNo ->
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PubKeyHash -> Integer -> DCert
PV1.DCertPoolRetire (forall (d :: KeyRole). KeyHash d -> PubKeyHash
transKeyHash KeyHash 'StakePool
poolId) (EpochNo -> Integer
transEpochNo EpochNo
retireEpochNo)
  TxCert era
_ -> forall a. Maybe a
Nothing

transPlutusPurpose ::
  (EraPlutusTxInfo l era, PlutusTxCert l ~ PV1.DCert) =>
  proxy l ->
  ProtVer ->
  AlonzoPlutusPurpose AsItem era ->
  Either (ContextError era) PV1.ScriptPurpose
transPlutusPurpose :: forall (l :: Language) era (proxy :: Language -> *).
(EraPlutusTxInfo l era, PlutusTxCert l ~ DCert) =>
proxy l
-> ProtVer
-> AlonzoPlutusPurpose AsItem era
-> Either (ContextError era) ScriptPurpose
transPlutusPurpose proxy l
proxy ProtVer
pv = \case
  AlonzoSpending (AsItem TxIn
txIn) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TxOutRef -> ScriptPurpose
PV1.Spending (TxIn -> TxOutRef
transTxIn TxIn
txIn)
  AlonzoMinting (AsItem PolicyID
policyId) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ CurrencySymbol -> ScriptPurpose
PV1.Minting (PolicyID -> CurrencySymbol
transPolicyID PolicyID
policyId)
  AlonzoCertifying (AsItem TxCert era
txCert) -> DCert -> ScriptPurpose
PV1.Certifying forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (l :: Language) era (proxy :: Language -> *).
EraPlutusTxInfo l era =>
proxy l
-> ProtVer
-> TxCert era
-> Either (ContextError era) (PlutusTxCert l)
toPlutusTxCert proxy l
proxy ProtVer
pv TxCert era
txCert
  AlonzoRewarding (AsItem RewardAccount
rewardAccount) ->
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ StakingCredential -> ScriptPurpose
PV1.Rewarding (Credential -> StakingCredential
PV1.StakingHash (RewardAccount -> Credential
transRewardAccount RewardAccount
rewardAccount))