{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# 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.Crypto (Crypto)
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 Cardano.Ledger.SafeHash (hashAnnotated)
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 Crypto c => EraPlutusTxInfo 'PlutusV1 (AlonzoEra c) where
  toPlutusTxCert :: forall (proxy :: Language -> *).
proxy 'PlutusV1
-> ProtVer
-> TxCert (AlonzoEra c)
-> Either (ContextError (AlonzoEra c)) (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 c)
-> Either
     (ContextError (AlonzoEra c)) (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 c)
-> Either (ContextError (AlonzoEra c)) (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 c)
ltiUTxO :: forall era. LedgerTxInfo era -> UTxO era
ltiUTxO :: UTxO (AlonzoEra c)
ltiUTxO, Tx (AlonzoEra c)
ltiTx :: forall era. LedgerTxInfo era -> Tx era
ltiTx :: Tx (AlonzoEra c)
ltiTx} = do
    POSIXTimeRange
timeRange <-
      forall (proxy :: * -> *) era a.
Inject (AlonzoContextError era) a =>
proxy era
-> ProtVer
-> EpochInfo (Either Text)
-> SystemStart
-> ValidityInterval
-> Either a POSIXTimeRange
transValidityInterval Tx (AlonzoEra c)
ltiTx ProtVer
ltiProtVer EpochInfo (Either Text)
ltiEpochInfo SystemStart
ltiSystemStart (TxBody (AlonzoEra c)
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 c)
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL)) forall a b. (a -> b) -> a -> b
$ \TxIn (EraCrypto (AlonzoEra c))
txIn -> do
      AlonzoTxOut (AlonzoEra c)
txOut <- forall era a.
Inject (AlonzoContextError era) a =>
UTxO era -> TxIn (EraCrypto era) -> Either a (TxOut era)
transLookupTxOut UTxO (AlonzoEra c)
ltiUTxO TxIn (EraCrypto (AlonzoEra c))
txIn
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TxOutRef -> TxOut -> TxInInfo
PV1.TxInInfo (forall c. TxIn c -> TxOutRef
transTxIn TxIn (EraCrypto (AlonzoEra c))
txIn) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era c.
(Value era ~ MaryValue c, AlonzoEraTxOut era) =>
TxOut era -> Maybe TxOut
transTxOut AlonzoTxOut (AlonzoEra c)
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 c)
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 c.
(Value era ~ MaryValue c, 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 c)
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 c)
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) Coin
feeTxBodyL)
        , txInfoMint :: Value
PV1.txInfoMint = forall c. MultiAsset c -> Value
transMintValue (TxBody (AlonzoEra c)
txBody forall s a. s -> Getting a s a -> a
^. forall era.
MaryEraTxBody era =>
Lens' (TxBody era) (MultiAsset (EraCrypto era))
mintTxBodyL)
        , txInfoDCert :: [DCert]
PV1.txInfoDCert = [DCert]
txCerts
        , txInfoWdrl :: [(StakingCredential, Integer)]
PV1.txInfoWdrl = forall era.
EraTxBody era =>
TxBody era -> [(StakingCredential, Integer)]
transTxBodyWithdrawals TxBody (AlonzoEra c)
txBody
        , txInfoValidRange :: POSIXTimeRange
PV1.txInfoValidRange = POSIXTimeRange
timeRange
        , txInfoSignatories :: [PubKeyHash]
PV1.txInfoSignatories = forall era. AlonzoEraTxBody era => TxBody era -> [PubKeyHash]
transTxBodyReqSignerHashes TxBody (AlonzoEra c)
txBody
        , txInfoData :: [(DatumHash, Datum)]
PV1.txInfoData = forall era.
AlonzoEraTxWits era =>
TxWits era -> [(DatumHash, Datum)]
transTxWitsDatums (Tx (AlonzoEra c)
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 c)
txBody
        }
    where
      txBody :: TxBody (AlonzoEra c)
txBody = Tx (AlonzoEra c)
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 c)
-> Maybe (Data (AlonzoEra c))
-> Data (AlonzoEra c)
-> Either (ContextError (AlonzoEra c)) (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 Crypto c => EraPlutusContext (AlonzoEra c) where
  type ContextError (AlonzoEra c) = AlonzoContextError (AlonzoEra c)

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

data AlonzoContextError era
  = TranslationLogicMissingInput !(TxIn (EraCrypto era))
  | TimeTranslationPastHorizon !Text
  deriving (AlonzoContextError era -> AlonzoContextError era -> Bool
forall era.
AlonzoContextError era -> AlonzoContextError era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AlonzoContextError era -> AlonzoContextError era -> Bool
$c/= :: forall era.
AlonzoContextError era -> AlonzoContextError era -> Bool
== :: AlonzoContextError era -> AlonzoContextError era -> Bool
$c== :: forall era.
AlonzoContextError era -> AlonzoContextError era -> Bool
Eq, Int -> AlonzoContextError era -> ShowS
forall era. Int -> AlonzoContextError era -> ShowS
forall era. [AlonzoContextError era] -> ShowS
forall era. AlonzoContextError era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AlonzoContextError era] -> ShowS
$cshowList :: forall era. [AlonzoContextError era] -> ShowS
show :: AlonzoContextError era -> String
$cshow :: forall era. AlonzoContextError era -> String
showsPrec :: Int -> AlonzoContextError era -> ShowS
$cshowsPrec :: forall era. Int -> AlonzoContextError era -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (AlonzoContextError era) x -> AlonzoContextError era
forall era x.
AlonzoContextError era -> Rep (AlonzoContextError era) x
$cto :: forall era x.
Rep (AlonzoContextError era) x -> AlonzoContextError era
$cfrom :: forall era 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 (EraCrypto era)
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 era. TxIn (EraCrypto era) -> 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 (EraCrypto era)
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 era. 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 era. TxIn (EraCrypto era) -> 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 era. 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 (EraCrypto era)
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
<> forall c. TxIn c -> Text
txInToText TxIn (EraCrypto era)
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 (EraCrypto era) ->
  Either a (TxOut era)
transLookupTxOut :: forall era a.
Inject (AlonzoContextError era) a =>
UTxO era -> TxIn (EraCrypto era) -> Either a (TxOut era)
transLookupTxOut (UTxO Map (TxIn (EraCrypto era)) (TxOut era)
utxo) TxIn (EraCrypto era)
txIn =
  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn (EraCrypto era)
txIn Map (TxIn (EraCrypto era)) (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 era. TxIn (EraCrypto era) -> AlonzoContextError era
TranslationLogicMissingInput @era TxIn (EraCrypto era)
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 (proxy :: * -> *) era 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 era. 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 c, AlonzoEraTxOut era) => TxOut era -> Maybe PV1.TxOut
transTxOut :: forall era c.
(Value era ~ MaryValue c, 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 (EraCrypto era)))
bootAddrTxOutF)
  let val :: MaryValue c
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 (EraCrypto era))
dataHash = TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraTxOut era =>
Lens' (TxOut era) (StrictMaybe (DataHash (EraCrypto era)))
dataHashTxOutL
  Address
address <- forall c. Addr c -> Maybe Address
transAddr (TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era.
EraTxOut era =>
Lens' (TxOut era) (Addr (EraCrypto era))
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 (forall c. MaryValue c -> Value
transValue MaryValue c
val) (forall c. DataHash c -> DatumHash
transDataHash forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe StrictMaybe (DataHash (EraCrypto era))
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 c i. SafeHash c i -> BuiltinByteString
transSafeHash (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
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 c -> Map.Map PV1.StakingCredential Integer
transWithdrawals :: forall c. Withdrawals c -> Map StakingCredential Integer
transWithdrawals (Withdrawals Map (RewardAcnt c) Coin
mp) = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' forall {c}.
Map StakingCredential Integer
-> RewardAccount c -> Coin -> Map StakingCredential Integer
accum forall k a. Map k a
Map.empty Map (RewardAcnt c) Coin
mp
  where
    accum :: Map StakingCredential Integer
-> RewardAccount c -> Coin -> Map StakingCredential Integer
accum Map StakingCredential Integer
ans RewardAccount c
rewardAccount (Coin Integer
n) =
      forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Credential -> StakingCredential
PV1.StakingHash (forall c. RewardAccount c -> Credential
transRewardAccount RewardAccount c
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 (forall c. Withdrawals c -> Map StakingCredential Integer
transWithdrawals (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (Withdrawals (EraCrypto era))
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) c. KeyHash d c -> 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 (EraCrypto era)))
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 c era. (DataHash c, 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 (EraCrypto era)) (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 c -> PV1.CurrencySymbol
transPolicyID :: forall c. PolicyID c -> CurrencySymbol
transPolicyID (PolicyID (ScriptHash Hash (ADDRHASH c) 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 c) 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 c -> PV1.Value
transMultiAsset :: forall c. MultiAsset c -> Value
transMultiAsset MultiAsset c
ma = forall c. MultiAsset c -> Value -> Value
transMultiAssetInternal MultiAsset c
ma forall a. Monoid a => a
mempty

transMultiAssetInternal :: MultiAsset c -> PV1.Value -> PV1.Value
transMultiAssetInternal :: forall c. MultiAsset c -> Value -> Value
transMultiAssetInternal (MultiAsset Map (PolicyID c) (Map AssetName Integer)
m) Value
initAcc = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' forall {c}. Value -> PolicyID c -> Map AssetName Integer -> Value
accum1 Value
initAcc Map (PolicyID c) (Map AssetName Integer)
m
  where
    accum1 :: Value -> PolicyID c -> Map AssetName Integer -> Value
accum1 Value
ans PolicyID c
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 (forall c. PolicyID c -> CurrencySymbol
transPolicyID PolicyID c
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 c -> PV1.Value
transMintValue :: forall c. MultiAsset c -> Value
transMintValue MultiAsset c
m = forall c. MultiAsset c -> Value -> Value
transMultiAssetInternal MultiAsset c
m (Coin -> Value
transCoinToValue forall t. Val t => t
zero)

transValue :: MaryValue c -> PV1.Value
transValue :: forall c. MaryValue c -> Value
transValue (MaryValue Coin
c MultiAsset c
m) = Coin -> Value
transCoinToValue Coin
c forall a. Semigroup a => a -> a -> a
<> forall c. MultiAsset c -> Value
transMultiAsset MultiAsset c
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 (EraCrypto era)
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) c. Credential kr c -> Credential
transCred StakeCredential (EraCrypto era)
stakeCred))
  UnRegTxCert StakeCredential (EraCrypto era)
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) c. Credential kr c -> Credential
transCred StakeCredential (EraCrypto era)
stakeCred))
  DelegStakeTxCert StakeCredential (EraCrypto era)
stakeCred KeyHash 'StakePool (EraCrypto era)
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) c. Credential kr c -> Credential
transCred StakeCredential (EraCrypto era)
stakeCred)) (forall (d :: KeyRole) c. KeyHash d c -> PubKeyHash
transKeyHash KeyHash 'StakePool (EraCrypto era)
keyHash)
  RegPoolTxCert (PoolParams {KeyHash 'StakePool (EraCrypto era)
ppId :: forall c. PoolParams c -> KeyHash 'StakePool c
ppId :: KeyHash 'StakePool (EraCrypto era)
ppId, Hash (EraCrypto era) (VerKeyVRF (EraCrypto era))
ppVrf :: forall c. PoolParams c -> Hash c (VerKeyVRF c)
ppVrf :: Hash (EraCrypto era) (VerKeyVRF (EraCrypto era))
ppVrf}) ->
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
      PubKeyHash -> PubKeyHash -> DCert
PV1.DCertPoolRegister (forall (d :: KeyRole) c. KeyHash d c -> PubKeyHash
transKeyHash KeyHash 'StakePool (EraCrypto era)
ppId) (BuiltinByteString -> PubKeyHash
PV1.PubKeyHash (forall a. HasToBuiltin a => a -> ToBuiltin a
PV1.toBuiltin (forall h a. Hash h a -> ByteString
hashToBytes Hash (EraCrypto era) (VerKeyVRF (EraCrypto era))
ppVrf)))
  RetirePoolTxCert KeyHash 'StakePool (EraCrypto era)
poolId EpochNo
retireEpochNo ->
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PubKeyHash -> Integer -> DCert
PV1.DCertPoolRetire (forall (d :: KeyRole) c. KeyHash d c -> PubKeyHash
transKeyHash KeyHash 'StakePool (EraCrypto era)
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 (EraCrypto era)
txIn) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ TxOutRef -> ScriptPurpose
PV1.Spending (forall c. TxIn c -> TxOutRef
transTxIn TxIn (EraCrypto era)
txIn)
  AlonzoMinting (AsItem PolicyID (EraCrypto era)
policyId) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ CurrencySymbol -> ScriptPurpose
PV1.Minting (forall c. PolicyID c -> CurrencySymbol
transPolicyID PolicyID (EraCrypto era)
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 (EraCrypto era)
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 (forall c. RewardAccount c -> Credential
transRewardAccount RewardAccount (EraCrypto era)
rewardAccount))