{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}

module Cardano.CLI.Compatible.Transaction.TxOut
  ( mkTxOut
  , toTxOutInAnyEra
  )
where

import Cardano.Api
import Cardano.Api.Experimental.Tx qualified as Exp
import Cardano.Api.Ledger qualified as L

import Cardano.CLI.Compatible.Exception
import Cardano.CLI.EraBased.Script.Read.Common
import Cardano.CLI.Orphan ()
import Cardano.CLI.Read
import Cardano.CLI.Type.Common
import Cardano.Ledger.Hashes (DataHash)
import Cardano.Ledger.Plutus.Data qualified as L

import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map

toTxOutInAnyEra
  :: ShelleyBasedEra era
  -> TxOutAnyEra
  -> CIO e (Exp.TxOut (ShelleyLedgerEra era), Map DataHash (L.Data (ShelleyLedgerEra era)))
toTxOutInAnyEra :: forall era e.
ShelleyBasedEra era
-> TxOutAnyEra
-> CIO
     e
     (TxOut (ShelleyLedgerEra era),
      Map DataHash (Data (ShelleyLedgerEra era)))
toTxOutInAnyEra ShelleyBasedEra era
era (TxOutAnyEra AddressAny
addr' Value
val' TxOutDatumAnyEra
mDatumHash ReferenceScriptAnyEra
refScriptFp) = do
  let addr :: AddressInEra era
addr = ShelleyBasedEra era -> AddressAny -> AddressInEra era
forall era. ShelleyBasedEra era -> AddressAny -> AddressInEra era
anyAddressInShelleyBasedEra ShelleyBasedEra era
era AddressAny
addr'
  ShelleyBasedEra era
-> AddressInEra era
-> Value
-> TxOutDatumAnyEra
-> ReferenceScriptAnyEra
-> CIO
     e
     (TxOut (ShelleyLedgerEra era),
      Map DataHash (Data (ShelleyLedgerEra era)))
forall era e.
ShelleyBasedEra era
-> AddressInEra era
-> Value
-> TxOutDatumAnyEra
-> ReferenceScriptAnyEra
-> CIO
     e
     (TxOut (ShelleyLedgerEra era),
      Map DataHash (Data (ShelleyLedgerEra era)))
mkTxOut ShelleyBasedEra era
era AddressInEra era
addr Value
val' TxOutDatumAnyEra
mDatumHash ReferenceScriptAnyEra
refScriptFp

-- | Build an output for a transaction body. Produces the experimental
-- 'Exp.TxOut' plus any supplemental datum bodies that the caller-supplied
-- datum carries. The legacy 'TxOut CtxTx era' bundled supplemental datums
-- inside outputs; 'Exp.TxOut' only carries the datum hash, so callers thread
-- the full datum bodies in separately (e.g. via 'createCompatibleTx').
--
-- The legacy 'TxOut CtxTx era' is used internally as a stepping stone to
-- reuse the api's 'toShelleyTxOutAny' field-level conversion logic; it is
-- not exposed.
mkTxOut
  :: ShelleyBasedEra era
  -> AddressInEra era
  -> Value
  -> TxOutDatumAnyEra
  -> ReferenceScriptAnyEra
  -> CIO e (Exp.TxOut (ShelleyLedgerEra era), Map DataHash (L.Data (ShelleyLedgerEra era)))
mkTxOut :: forall era e.
ShelleyBasedEra era
-> AddressInEra era
-> Value
-> TxOutDatumAnyEra
-> ReferenceScriptAnyEra
-> CIO
     e
     (TxOut (ShelleyLedgerEra era),
      Map DataHash (Data (ShelleyLedgerEra era)))
mkTxOut ShelleyBasedEra era
sbe AddressInEra era
addr Value
val' TxOutDatumAnyEra
mDatumHash ReferenceScriptAnyEra
refScriptFp = do
  let era :: CardanoEra era
era = ShelleyBasedEra era -> CardanoEra era
forall era. ShelleyBasedEra era -> CardanoEra era
forall (eon :: * -> *) era.
ToCardanoEra eon =>
eon era -> CardanoEra era
toCardanoEra ShelleyBasedEra era
sbe
  val <- ShelleyBasedEra era -> Value -> CIO e (TxOutValue era)
forall era e.
ShelleyBasedEra era -> Value -> CIO e (TxOutValue era)
toTxOutValueInShelleyBasedEra ShelleyBasedEra era
sbe Value
val'

  datum <-
    inEonForEra
      (pure TxOutDatumNone)
      (`toTxAlonzoDatum` mDatumHash)
      era

  refScript <-
    inEonForEra
      (pure ReferenceScriptNone)
      (`getReferenceScript` refScriptFp)
      era

  let legacyTxOut = AddressInEra era
-> TxOutValue era
-> TxOutDatum CtxTx era
-> ReferenceScript era
-> TxOut CtxTx era
forall ctx era.
AddressInEra era
-> TxOutValue era
-> TxOutDatum ctx era
-> ReferenceScript era
-> TxOut ctx era
TxOut AddressInEra era
addr TxOutValue era
val TxOutDatum CtxTx era
datum ReferenceScript era
refScript
  pure $
    shelleyBasedEraConstraints sbe $
      (Exp.TxOut (toShelleyTxOutAny sbe legacyTxOut), supplementalsOf datum)
 where
  supplementalsOf
    :: L.Era (ShelleyLedgerEra era)
    => TxOutDatum CtxTx era
    -> Map DataHash (L.Data (ShelleyLedgerEra era))
  supplementalsOf :: forall era.
Era (ShelleyLedgerEra era) =>
TxOutDatum CtxTx era -> Map DataHash (Data (ShelleyLedgerEra era))
supplementalsOf (TxOutSupplementalDatum AlonzoEraOnwards era
_ HashableScriptData
h) =
    let ld :: Data (ShelleyLedgerEra era)
ld = HashableScriptData -> Data (ShelleyLedgerEra era)
forall ledgerera.
Era ledgerera =>
HashableScriptData -> Data ledgerera
toAlonzoData HashableScriptData
h
     in DataHash
-> Data (ShelleyLedgerEra era)
-> Map DataHash (Data (ShelleyLedgerEra era))
forall k a. k -> a -> Map k a
Map.singleton (Data (ShelleyLedgerEra era) -> DataHash
forall era. Data era -> DataHash
L.hashData Data (ShelleyLedgerEra era)
ld) Data (ShelleyLedgerEra era)
ld
  supplementalsOf TxOutDatum CtxTx era
_ = Map DataHash (Data (ShelleyLedgerEra era))
forall a. Monoid a => a
mempty

toTxOutValueInShelleyBasedEra
  :: ShelleyBasedEra era
  -> Value
  -> CIO e (TxOutValue era)
toTxOutValueInShelleyBasedEra :: forall era e.
ShelleyBasedEra era -> Value -> CIO e (TxOutValue era)
toTxOutValueInShelleyBasedEra ShelleyBasedEra era
sbe Value
val =
  (ShelleyToAllegraEraConstraints era =>
 ShelleyToAllegraEra era -> RIO e (TxOutValue era))
-> (MaryEraOnwardsConstraints era =>
    MaryEraOnwards era -> RIO e (TxOutValue era))
-> ShelleyBasedEra era
-> RIO e (TxOutValue era)
forall era a.
(ShelleyToAllegraEraConstraints era =>
 ShelleyToAllegraEra era -> a)
-> (MaryEraOnwardsConstraints era => MaryEraOnwards era -> a)
-> ShelleyBasedEra era
-> a
caseShelleyToAllegraOrMaryEraOnwards
    ( \ShelleyToAllegraEra era
_ -> case Value -> Maybe Coin
valueToLovelace Value
val of
        Just Coin
l -> TxOutValue era -> RIO e (TxOutValue era)
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return (ShelleyBasedEra era
-> Value (ShelleyLedgerEra era) -> TxOutValue era
forall era.
(Eq (Value (ShelleyLedgerEra era)),
 Show (Value (ShelleyLedgerEra era))) =>
ShelleyBasedEra era
-> Value (ShelleyLedgerEra era) -> TxOutValue era
TxOutValueShelleyBased ShelleyBasedEra era
sbe Value (ShelleyLedgerEra era)
Coin
l)
        Maybe Coin
Nothing -> ShelleyBasedEra era -> TxFeature -> CIO e (TxOutValue era)
forall (eon :: * -> *) era e a.
ToCardanoEra eon =>
eon era -> TxFeature -> CIO e a
txFeatureMismatch ShelleyBasedEra era
sbe TxFeature
TxFeatureMultiAssetOutputs
    )
    (\MaryEraOnwards era
w -> TxOutValue era -> RIO e (TxOutValue era)
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return (ShelleyBasedEra era
-> Value (ShelleyLedgerEra era) -> TxOutValue era
forall era.
(Eq (Value (ShelleyLedgerEra era)),
 Show (Value (ShelleyLedgerEra era))) =>
ShelleyBasedEra era
-> Value (ShelleyLedgerEra era) -> TxOutValue era
TxOutValueShelleyBased ShelleyBasedEra era
sbe (MaryEraOnwards era -> Value -> Value (ShelleyLedgerEra era)
forall era.
MaryEraOnwards era -> Value -> Value (ShelleyLedgerEra era)
toLedgerValue MaryEraOnwards era
w Value
val)))
    ShelleyBasedEra era
sbe

toTxAlonzoDatum
  :: ()
  => AlonzoEraOnwards era
  -> TxOutDatumAnyEra
  -> CIO e (TxOutDatum CtxTx era)
toTxAlonzoDatum :: forall era e.
AlonzoEraOnwards era
-> TxOutDatumAnyEra -> CIO e (TxOutDatum CtxTx era)
toTxAlonzoDatum AlonzoEraOnwards era
supp TxOutDatumAnyEra
cliDatum =
  case TxOutDatumAnyEra
cliDatum of
    TxOutDatumAnyEra
TxOutDatumByNone -> TxOutDatum CtxTx era -> RIO e (TxOutDatum CtxTx era)
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TxOutDatum CtxTx era
forall ctx era. TxOutDatum ctx era
TxOutDatumNone
    TxOutDatumByHashOnly Hash ScriptData
h -> TxOutDatum CtxTx era -> RIO e (TxOutDatum CtxTx era)
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AlonzoEraOnwards era -> Hash ScriptData -> TxOutDatum CtxTx era
forall era ctx.
AlonzoEraOnwards era -> Hash ScriptData -> TxOutDatum ctx era
TxOutDatumHash AlonzoEraOnwards era
supp Hash ScriptData
h)
    TxOutDatumByHashOf ScriptDataOrFile
sDataOrFile -> do
      sData <- ExceptT ScriptDataError IO HashableScriptData
-> RIO e HashableScriptData
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
ExceptT e IO a -> m a
fromExceptTCli (ExceptT ScriptDataError IO HashableScriptData
 -> RIO e HashableScriptData)
-> ExceptT ScriptDataError IO HashableScriptData
-> RIO e HashableScriptData
forall a b. (a -> b) -> a -> b
$ ScriptDataOrFile -> ExceptT ScriptDataError IO HashableScriptData
forall (m :: * -> *).
MonadIO m =>
ScriptDataOrFile -> ExceptT ScriptDataError m HashableScriptData
readScriptDataOrFile ScriptDataOrFile
sDataOrFile
      pure (TxOutDatumHash supp $ hashScriptDataBytes sData)
    TxOutDatumByValue ScriptDataOrFile
sDataOrFile -> do
      sData <- ExceptT ScriptDataError IO HashableScriptData
-> RIO e HashableScriptData
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
ExceptT e IO a -> m a
fromExceptTCli (ExceptT ScriptDataError IO HashableScriptData
 -> RIO e HashableScriptData)
-> ExceptT ScriptDataError IO HashableScriptData
-> RIO e HashableScriptData
forall a b. (a -> b) -> a -> b
$ ScriptDataOrFile -> ExceptT ScriptDataError IO HashableScriptData
forall (m :: * -> *).
MonadIO m =>
ScriptDataOrFile -> ExceptT ScriptDataError m HashableScriptData
readScriptDataOrFile ScriptDataOrFile
sDataOrFile
      pure (TxOutSupplementalDatum supp sData)
    TxOutInlineDatumByValue ScriptDataOrFile
sDataOrFile -> do
      let cEra :: CardanoEra era
cEra = AlonzoEraOnwards era -> CardanoEra era
forall era. AlonzoEraOnwards era -> CardanoEra era
forall (eon :: * -> *) era.
ToCardanoEra eon =>
eon era -> CardanoEra era
toCardanoEra AlonzoEraOnwards era
supp
      CardanoEra era
-> RIO e (TxOutDatum CtxTx era)
-> (BabbageEraOnwards era -> RIO e (TxOutDatum CtxTx era))
-> RIO e (TxOutDatum CtxTx era)
forall (eon :: * -> *) era a.
Eon eon =>
CardanoEra era -> a -> (eon era -> a) -> a
forEraInEon CardanoEra era
cEra (CardanoEra era -> TxFeature -> CIO e (TxOutDatum CtxTx era)
forall (eon :: * -> *) era e a.
ToCardanoEra eon =>
eon era -> TxFeature -> CIO e a
txFeatureMismatch CardanoEra era
cEra TxFeature
TxFeatureInlineDatums) ((BabbageEraOnwards era -> RIO e (TxOutDatum CtxTx era))
 -> RIO e (TxOutDatum CtxTx era))
-> (BabbageEraOnwards era -> RIO e (TxOutDatum CtxTx era))
-> RIO e (TxOutDatum CtxTx era)
forall a b. (a -> b) -> a -> b
$ \BabbageEraOnwards era
babbageOnwards -> do
        sData <- ExceptT ScriptDataError IO HashableScriptData
-> RIO e HashableScriptData
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
ExceptT e IO a -> m a
fromExceptTCli (ExceptT ScriptDataError IO HashableScriptData
 -> RIO e HashableScriptData)
-> ExceptT ScriptDataError IO HashableScriptData
-> RIO e HashableScriptData
forall a b. (a -> b) -> a -> b
$ ScriptDataOrFile -> ExceptT ScriptDataError IO HashableScriptData
forall (m :: * -> *).
MonadIO m =>
ScriptDataOrFile -> ExceptT ScriptDataError m HashableScriptData
readScriptDataOrFile ScriptDataOrFile
sDataOrFile
        pure $ TxOutDatumInline babbageOnwards sData

getReferenceScript
  :: BabbageEraOnwards era
  -> ReferenceScriptAnyEra
  -> CIO e (ReferenceScript era)
getReferenceScript :: forall era e.
BabbageEraOnwards era
-> ReferenceScriptAnyEra -> CIO e (ReferenceScript era)
getReferenceScript BabbageEraOnwards era
w = \case
  ReferenceScriptAnyEra
ReferenceScriptAnyEraNone -> ReferenceScript era -> RIO e (ReferenceScript era)
forall a. a -> RIO e a
forall (m :: * -> *) a. Monad m => a -> m a
return ReferenceScript era
forall era. ReferenceScript era
ReferenceScriptNone
  ReferenceScriptAnyEra FilePath
fp -> BabbageEraOnwards era -> ScriptInAnyLang -> ReferenceScript era
forall era.
BabbageEraOnwards era -> ScriptInAnyLang -> ReferenceScript era
ReferenceScript BabbageEraOnwards era
w (ScriptInAnyLang -> ReferenceScript era)
-> RIO e ScriptInAnyLang -> RIO e (ReferenceScript era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> RIO e ScriptInAnyLang
forall (m :: * -> *). MonadIO m => FilePath -> m ScriptInAnyLang
readFileScriptInAnyLang FilePath
fp

-- | An enumeration of era-dependent features where we have to check that it
-- is permissible to use this feature in this era.
data TxFeature
  = TxFeatureMultiAssetOutputs
  | TxFeatureInlineDatums
  deriving Int -> TxFeature -> ShowS
[TxFeature] -> ShowS
TxFeature -> FilePath
(Int -> TxFeature -> ShowS)
-> (TxFeature -> FilePath)
-> ([TxFeature] -> ShowS)
-> Show TxFeature
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TxFeature -> ShowS
showsPrec :: Int -> TxFeature -> ShowS
$cshow :: TxFeature -> FilePath
show :: TxFeature -> FilePath
$cshowList :: [TxFeature] -> ShowS
showList :: [TxFeature] -> ShowS
Show

renderFeature :: TxFeature -> Text
renderFeature :: TxFeature -> Text
renderFeature = \case
  TxFeature
TxFeatureMultiAssetOutputs -> Text
"Multi-Asset outputs"
  TxFeature
TxFeatureInlineDatums -> Text
"Inline datums"

data TxCmdTxFeatureMismatch = TxCmdTxFeatureMismatch !AnyCardanoEra !TxFeature deriving Int -> TxCmdTxFeatureMismatch -> ShowS
[TxCmdTxFeatureMismatch] -> ShowS
TxCmdTxFeatureMismatch -> FilePath
(Int -> TxCmdTxFeatureMismatch -> ShowS)
-> (TxCmdTxFeatureMismatch -> FilePath)
-> ([TxCmdTxFeatureMismatch] -> ShowS)
-> Show TxCmdTxFeatureMismatch
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TxCmdTxFeatureMismatch -> ShowS
showsPrec :: Int -> TxCmdTxFeatureMismatch -> ShowS
$cshow :: TxCmdTxFeatureMismatch -> FilePath
show :: TxCmdTxFeatureMismatch -> FilePath
$cshowList :: [TxCmdTxFeatureMismatch] -> ShowS
showList :: [TxCmdTxFeatureMismatch] -> ShowS
Show

instance Error TxCmdTxFeatureMismatch where
  prettyError :: forall ann. TxCmdTxFeatureMismatch -> Doc ann
prettyError (TxCmdTxFeatureMismatch (AnyCardanoEra CardanoEra era
era) TxFeature
feature) =
    Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc ann) -> Text -> Doc ann
forall a b. (a -> b) -> a -> b
$
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ TxFeature -> Text
renderFeature TxFeature
feature
        , Text
" cannot be used for "
        , CardanoEra era -> Text
forall a. CardanoEra a -> Text
eraToStringKey CardanoEra era
era
        , Text
" era transactions."
        ]

txFeatureMismatch
  :: ()
  => ToCardanoEra eon
  => eon era
  -> TxFeature
  -> CIO e a
txFeatureMismatch :: forall (eon :: * -> *) era e a.
ToCardanoEra eon =>
eon era -> TxFeature -> CIO e a
txFeatureMismatch eon era
eon TxFeature
feature =
  TxCmdTxFeatureMismatch -> RIO e a
forall e (m :: * -> *) a.
(HasCallStack, Show e, Typeable e, Error e, MonadIO m) =>
e -> m a
throwCliError (TxCmdTxFeatureMismatch -> RIO e a)
-> TxCmdTxFeatureMismatch -> RIO e a
forall a b. (a -> b) -> a -> b
$ AnyCardanoEra -> TxFeature -> TxCmdTxFeatureMismatch
TxCmdTxFeatureMismatch (CardanoEra era -> AnyCardanoEra
forall era. CardanoEra era -> AnyCardanoEra
anyCardanoEra (CardanoEra era -> AnyCardanoEra)
-> CardanoEra era -> AnyCardanoEra
forall a b. (a -> b) -> a -> b
$ eon era -> CardanoEra era
forall era. eon era -> CardanoEra era
forall (eon :: * -> *) era.
ToCardanoEra eon =>
eon era -> CardanoEra era
toCardanoEra eon era
eon) TxFeature
feature

eraToStringKey :: CardanoEra a -> Text
eraToStringKey :: forall a. CardanoEra a -> Text
eraToStringKey = Doc AnsiStyle -> Text
docToText (Doc AnsiStyle -> Text)
-> (CardanoEra a -> Doc AnsiStyle) -> CardanoEra a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CardanoEra a -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
forall ann. CardanoEra a -> Doc ann
pretty