{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}

{-|

Interface to the transaction types from 'cardano-api'

-}
module Plutus.Contract.CardanoAPI(
    fromCardanoBlock
  , fromCardanoTx
  , setValidity
  , fromCardanoTxOut
  , fromCardanoTxOutRefScript
  , module Export
) where

import Cardano.Api qualified as C
import Cardano.Api.Shelley qualified as C
import Data.Either (fromRight)
import Data.List (sort)
import Ledger qualified as P
import Ledger.Tx.CardanoAPI as Export
import Plutus.ChainIndex.Types (ChainIndexTx (..), ChainIndexTxOut (..), ChainIndexTxOutputs (..), ReferenceScript (..))

fromCardanoBlock :: C.BlockInMode C.CardanoMode -> [ChainIndexTx]
fromCardanoBlock :: BlockInMode CardanoMode -> [ChainIndexTx]
fromCardanoBlock (C.BlockInMode (C.Block C.BlockHeader {} [Tx era]
txs) EraInMode era CardanoMode
eraInMode) =
  (Tx era -> ChainIndexTx) -> [Tx era] -> [ChainIndexTx]
forall a b. (a -> b) -> [a] -> [b]
map (EraInMode era CardanoMode -> Tx era -> ChainIndexTx
forall era.
IsCardanoEra era =>
EraInMode era CardanoMode -> Tx era -> ChainIndexTx
fromCardanoTx EraInMode era CardanoMode
eraInMode) [Tx era]
txs

-- | Convert a Cardano API tx of any given era to a Plutus chain index tx.
fromCardanoTx
  :: C.IsCardanoEra era
  => C.EraInMode era C.CardanoMode
  -> C.Tx era
  -> ChainIndexTx
fromCardanoTx :: EraInMode era CardanoMode -> Tx era -> ChainIndexTx
fromCardanoTx EraInMode era CardanoMode
eraInMode tx :: Tx era
tx@(C.Tx txBody :: TxBody era
txBody@(C.TxBody C.TxBodyContent{TxIns ViewTx era
[TxOut CtxTx era]
(TxValidityLowerBound era, TxValidityUpperBound era)
TxScriptValidity era
BuildTxWith ViewTx (Maybe ProtocolParameters)
TxInsCollateral era
TxInsReference ViewTx era
TxReturnCollateral CtxTx era
TxTotalCollateral era
TxFee era
TxMetadataInEra era
TxAuxScripts era
TxExtraKeyWitnesses era
TxWithdrawals ViewTx era
TxCertificates ViewTx era
TxUpdateProposal era
TxMintValue ViewTx era
txIns :: forall build era. TxBodyContent build era -> TxIns build era
txInsCollateral :: forall build era. TxBodyContent build era -> TxInsCollateral era
txInsReference :: forall build era.
TxBodyContent build era -> TxInsReference build era
txOuts :: forall build era. TxBodyContent build era -> [TxOut CtxTx era]
txTotalCollateral :: forall build era. TxBodyContent build era -> TxTotalCollateral era
txReturnCollateral :: forall build era.
TxBodyContent build era -> TxReturnCollateral CtxTx era
txFee :: forall build era. TxBodyContent build era -> TxFee era
txValidityRange :: forall build era.
TxBodyContent build era
-> (TxValidityLowerBound era, TxValidityUpperBound era)
txMetadata :: forall build era. TxBodyContent build era -> TxMetadataInEra era
txAuxScripts :: forall build era. TxBodyContent build era -> TxAuxScripts era
txExtraKeyWits :: forall build era.
TxBodyContent build era -> TxExtraKeyWitnesses era
txProtocolParams :: forall build era.
TxBodyContent build era
-> BuildTxWith build (Maybe ProtocolParameters)
txWithdrawals :: forall build era.
TxBodyContent build era -> TxWithdrawals build era
txCertificates :: forall build era.
TxBodyContent build era -> TxCertificates build era
txUpdateProposal :: forall build era. TxBodyContent build era -> TxUpdateProposal era
txMintValue :: forall build era. TxBodyContent build era -> TxMintValue build era
txScriptValidity :: forall build era. TxBodyContent build era -> TxScriptValidity era
txScriptValidity :: TxScriptValidity era
txMintValue :: TxMintValue ViewTx era
txUpdateProposal :: TxUpdateProposal era
txCertificates :: TxCertificates ViewTx era
txWithdrawals :: TxWithdrawals ViewTx era
txProtocolParams :: BuildTxWith ViewTx (Maybe ProtocolParameters)
txExtraKeyWits :: TxExtraKeyWitnesses era
txAuxScripts :: TxAuxScripts era
txMetadata :: TxMetadataInEra era
txValidityRange :: (TxValidityLowerBound era, TxValidityUpperBound era)
txFee :: TxFee era
txReturnCollateral :: TxReturnCollateral CtxTx era
txTotalCollateral :: TxTotalCollateral era
txOuts :: [TxOut CtxTx era]
txInsReference :: TxInsReference ViewTx era
txInsCollateral :: TxInsCollateral era
txIns :: TxIns ViewTx era
..}) [KeyWitness era]
_) =
    let txOutputs :: [ChainIndexTxOut]
txOutputs = (TxOut CtxTx era -> ChainIndexTxOut)
-> [TxOut CtxTx era] -> [ChainIndexTxOut]
forall a b. (a -> b) -> [a] -> [b]
map TxOut CtxTx era -> ChainIndexTxOut
forall era. IsCardanoEra era => TxOut CtxTx era -> ChainIndexTxOut
fromCardanoTxOut [TxOut CtxTx era]
txOuts
        scriptMap :: Map ScriptHash (Versioned Script)
scriptMap = TxBody era -> Map ScriptHash (Versioned Script)
forall era. TxBody era -> Map ScriptHash (Versioned Script)
plutusScriptsFromTxBody TxBody era
txBody
        isTxScriptValid :: Bool
isTxScriptValid = TxScriptValidity era -> Bool
forall era. TxScriptValidity era -> Bool
fromTxScriptValidity TxScriptValidity era
txScriptValidity
        (Map DatumHash Datum
datums, Redeemers
redeemers) = TxBody era -> (Map DatumHash Datum, Redeemers)
forall era. TxBody era -> (Map DatumHash Datum, Redeemers)
scriptDataFromCardanoTxBody TxBody era
txBody
        -- We need to sort the inputs as the order is important
        -- to find the corresponding redeemers
        inputs :: [TxIn]
inputs = [TxIn] -> [TxIn]
forall a. Ord a => [a] -> [a]
sort ([TxIn] -> [TxIn]) -> [TxIn] -> [TxIn]
forall a b. (a -> b) -> a -> b
$
          if Bool
isTxScriptValid
            then (TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn era)) -> TxIn
forall a b. (a, b) -> a
fst ((TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn era)) -> TxIn)
-> TxIns ViewTx era -> [TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxIns ViewTx era
txIns
            else case TxInsCollateral era
txInsCollateral of
                   TxInsCollateral era
C.TxInsCollateralNone     -> []
                   C.TxInsCollateral CollateralSupportedInEra era
_ [TxIn]
txins -> [TxIn]
txins
        collateralOut :: Maybe ChainIndexTxOut
collateralOut = case TxReturnCollateral CtxTx era
txReturnCollateral of
          TxReturnCollateral CtxTx era
C.TxReturnCollateralNone     -> Maybe ChainIndexTxOut
forall a. Maybe a
Nothing
          C.TxReturnCollateral TxTotalAndReturnCollateralSupportedInEra era
_ TxOut CtxTx era
txOut -> ChainIndexTxOut -> Maybe ChainIndexTxOut
forall a. a -> Maybe a
Just (ChainIndexTxOut -> Maybe ChainIndexTxOut)
-> ChainIndexTxOut -> Maybe ChainIndexTxOut
forall a b. (a -> b) -> a -> b
$ TxOut CtxTx era -> ChainIndexTxOut
forall era. IsCardanoEra era => TxOut CtxTx era -> ChainIndexTxOut
fromCardanoTxOut TxOut CtxTx era
txOut

    in ChainIndexTx :: TxId
-> [TxIn]
-> ChainIndexTxOutputs
-> SlotRange
-> Map DatumHash Datum
-> Redeemers
-> Map ScriptHash (Versioned Script)
-> Maybe CardanoTx
-> ChainIndexTx
ChainIndexTx
            { _citxTxId :: TxId
_citxTxId = TxId -> TxId
fromCardanoTxId (TxBody era -> TxId
forall era. TxBody era -> TxId
C.getTxId TxBody era
txBody)
            , _citxValidRange :: SlotRange
_citxValidRange = (TxValidityLowerBound era, TxValidityUpperBound era) -> SlotRange
forall era.
(TxValidityLowerBound era, TxValidityUpperBound era) -> SlotRange
fromCardanoValidityRange (TxValidityLowerBound era, TxValidityUpperBound era)
txValidityRange
            -- If the transaction is invalid, we use collateral inputs
            , _citxInputs :: [TxIn]
_citxInputs = (TxIn -> TxIn) -> [TxIn] -> [TxIn]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TxOutRef -> Maybe TxInType -> TxIn
`P.TxIn` Maybe TxInType
forall a. Maybe a
Nothing) (TxOutRef -> TxIn) -> (TxIn -> TxOutRef) -> TxIn -> TxIn
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxIn -> TxOutRef
fromCardanoTxIn) [TxIn]
inputs
            -- No outputs if the one of scripts failed
            , _citxOutputs :: ChainIndexTxOutputs
_citxOutputs = if Bool
isTxScriptValid then [ChainIndexTxOut] -> ChainIndexTxOutputs
ValidTx [ChainIndexTxOut]
txOutputs
                                                else Maybe ChainIndexTxOut -> ChainIndexTxOutputs
InvalidTx Maybe ChainIndexTxOut
collateralOut
            , _citxData :: Map DatumHash Datum
_citxData = Map DatumHash Datum
datums
            , _citxRedeemers :: Redeemers
_citxRedeemers = Redeemers
redeemers
            , _citxScripts :: Map ScriptHash (Versioned Script)
_citxScripts = Map ScriptHash (Versioned Script)
scriptMap
            , _citxCardanoTx :: Maybe CardanoTx
_citxCardanoTx = CardanoTx -> Maybe CardanoTx
forall a. a -> Maybe a
Just (CardanoTx -> Maybe CardanoTx) -> CardanoTx -> Maybe CardanoTx
forall a b. (a -> b) -> a -> b
$ Tx era -> EraInMode era CardanoMode -> CardanoTx
forall era.
IsCardanoEra era =>
Tx era -> EraInMode era CardanoMode -> CardanoTx
CardanoTx Tx era
tx EraInMode era CardanoMode
eraInMode
            }

fromCardanoTxOut :: C.IsCardanoEra era => C.TxOut C.CtxTx era -> ChainIndexTxOut
fromCardanoTxOut :: TxOut CtxTx era -> ChainIndexTxOut
fromCardanoTxOut (C.TxOut AddressInEra era
addr TxOutValue era
val TxOutDatum CtxTx era
datum ReferenceScript era
refScript) =
    CardanoAddress
-> Value -> OutputDatum -> ReferenceScript -> ChainIndexTxOut
ChainIndexTxOut
        (CardanoAddress
-> Either EraCastError CardanoAddress -> CardanoAddress
forall b a. b -> Either a b -> b
fromRight ([Char] -> CardanoAddress
forall a. HasCallStack => [Char] -> a
error [Char]
"BabbageEra should be the latest era") (Either EraCastError CardanoAddress -> CardanoAddress)
-> Either EraCastError CardanoAddress -> CardanoAddress
forall a b. (a -> b) -> a -> b
$ CardanoEra BabbageEra
-> AddressInEra era -> Either EraCastError CardanoAddress
forall (f :: * -> *) fromEra toEra.
(EraCast f, IsCardanoEra fromEra, IsCardanoEra toEra) =>
CardanoEra toEra -> f fromEra -> Either EraCastError (f toEra)
C.eraCast CardanoEra BabbageEra
C.BabbageEra AddressInEra era
addr)
        (TxOutValue era -> Value
forall era. TxOutValue era -> Value
C.txOutValueToValue TxOutValue era
val)
        (TxOutDatum CtxTx era -> OutputDatum
forall era. TxOutDatum CtxTx era -> OutputDatum
fromCardanoTxOutDatum TxOutDatum CtxTx era
datum)
        (ReferenceScript era -> ReferenceScript
forall era. ReferenceScript era -> ReferenceScript
fromCardanoTxOutRefScript ReferenceScript era
refScript)

setValidity :: Bool -> C.Tx era -> C.Tx era
setValidity :: Bool -> Tx era -> Tx era
setValidity Bool
validity (C.Tx (C.ShelleyTxBody ShelleyBasedEra era
shelleyBasedEra TxBody (ShelleyLedgerEra era)
txBody [Script (ShelleyLedgerEra era)]
scripts TxBodyScriptData era
dat Maybe (AuxiliaryData (ShelleyLedgerEra era))
aux TxScriptValidity era
_) [KeyWitness era]
era) =
  TxBody era -> [KeyWitness era] -> Tx era
forall era. TxBody era -> [KeyWitness era] -> Tx era
C.Tx (ShelleyBasedEra era
-> TxBody (ShelleyLedgerEra era)
-> [Script (ShelleyLedgerEra era)]
-> TxBodyScriptData era
-> Maybe (AuxiliaryData (ShelleyLedgerEra era))
-> TxScriptValidity era
-> TxBody era
forall era.
ShelleyBasedEra era
-> TxBody (ShelleyLedgerEra era)
-> [Script (ShelleyLedgerEra era)]
-> TxBodyScriptData era
-> Maybe (AuxiliaryData (ShelleyLedgerEra era))
-> TxScriptValidity era
-> TxBody era
C.ShelleyTxBody ShelleyBasedEra era
shelleyBasedEra TxBody (ShelleyLedgerEra era)
txBody [Script (ShelleyLedgerEra era)]
scripts TxBodyScriptData era
dat Maybe (AuxiliaryData (ShelleyLedgerEra era))
aux (ShelleyBasedEra era -> Bool -> TxScriptValidity era
forall era. ShelleyBasedEra era -> Bool -> TxScriptValidity era
toTxScriptValidity ShelleyBasedEra era
shelleyBasedEra Bool
validity)) [KeyWitness era]
era
setValidity Bool
_ Tx era
tx = Tx era
tx -- @setValidity@ only applies in Alonzo era (and newer)

fromCardanoTxOutRefScript :: C.ReferenceScript era -> ReferenceScript
fromCardanoTxOutRefScript :: ReferenceScript era -> ReferenceScript
fromCardanoTxOutRefScript = \case
    ReferenceScript era
C.ReferenceScriptNone      -> ReferenceScript
ReferenceScriptNone
    C.ReferenceScript ReferenceTxInsScriptsInlineDatumsSupportedInEra era
_ ScriptInAnyLang
script -> ScriptInAnyLang -> ReferenceScript
ReferenceScriptInAnyLang ScriptInAnyLang
script