{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}

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

import Cardano.Api

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 Data.Text (Text)

toTxOutInAnyEra
  :: ShelleyBasedEra era
  -> TxOutAnyEra
  -> CIO e (TxOut CtxTx era)
toTxOutInAnyEra :: forall era e.
ShelleyBasedEra era -> TxOutAnyEra -> CIO e (TxOut CtxTx 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 CtxTx era)
forall era e.
ShelleyBasedEra era
-> AddressInEra era
-> Value
-> TxOutDatumAnyEra
-> ReferenceScriptAnyEra
-> CIO e (TxOut CtxTx era)
mkTxOut ShelleyBasedEra era
era AddressInEra era
addr Value
val' TxOutDatumAnyEra
mDatumHash ReferenceScriptAnyEra
refScriptFp

mkTxOut
  :: ShelleyBasedEra era
  -> AddressInEra era
  -> Value
  -> TxOutDatumAnyEra
  -> ReferenceScriptAnyEra
  -> CIO e (TxOut CtxTx era)
mkTxOut :: forall era e.
ShelleyBasedEra era
-> AddressInEra era
-> Value
-> TxOutDatumAnyEra
-> ReferenceScriptAnyEra
-> CIO e (TxOut CtxTx 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
  TxOutValue era
val <- ShelleyBasedEra era -> Value -> CIO e (TxOutValue era)
forall era e.
ShelleyBasedEra era -> Value -> CIO e (TxOutValue era)
toTxOutValueInShelleyBasedEra ShelleyBasedEra era
sbe Value
val'

  TxOutDatum CtxTx era
datum <-
    RIO e (TxOutDatum CtxTx era)
-> (AlonzoEraOnwards era -> RIO e (TxOutDatum CtxTx era))
-> CardanoEra era
-> RIO e (TxOutDatum CtxTx era)
forall a era.
a -> (AlonzoEraOnwards era -> a) -> CardanoEra era -> a
forall (eon :: * -> *) a era.
Eon eon =>
a -> (eon era -> a) -> CardanoEra era -> a
inEonForEra
      (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)
      (AlonzoEraOnwards era
-> TxOutDatumAnyEra -> CIO e (TxOutDatum CtxTx era)
forall era e.
AlonzoEraOnwards era
-> TxOutDatumAnyEra -> CIO e (TxOutDatum CtxTx era)
`toTxAlonzoDatum` TxOutDatumAnyEra
mDatumHash)
      CardanoEra era
era

  ReferenceScript era
refScript <-
    RIO e (ReferenceScript era)
-> (BabbageEraOnwards era -> RIO e (ReferenceScript era))
-> CardanoEra era
-> RIO e (ReferenceScript era)
forall a era.
a -> (BabbageEraOnwards era -> a) -> CardanoEra era -> a
forall (eon :: * -> *) a era.
Eon eon =>
a -> (eon era -> a) -> CardanoEra era -> a
inEonForEra
      (ReferenceScript era -> RIO e (ReferenceScript era)
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ReferenceScript era
forall era. ReferenceScript era
ReferenceScriptNone)
      (BabbageEraOnwards era
-> ReferenceScriptAnyEra -> CIO e (ReferenceScript era)
forall era e.
BabbageEraOnwards era
-> ReferenceScriptAnyEra -> CIO e (ReferenceScript era)
`getReferenceScript` ReferenceScriptAnyEra
refScriptFp)
      CardanoEra era
era

  TxOut CtxTx era -> RIO e (TxOut CtxTx era)
forall a. a -> RIO e a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxOut CtxTx era -> RIO e (TxOut CtxTx era))
-> TxOut CtxTx era -> RIO e (TxOut CtxTx era)
forall a b. (a -> b) -> a -> b
$ 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

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
      HashableScriptData
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
      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 -> TxOutDatum CtxTx era)
-> Hash ScriptData -> TxOutDatum CtxTx era
forall a b. (a -> b) -> a -> b
$ HashableScriptData -> Hash ScriptData
hashScriptDataBytes HashableScriptData
sData)
    TxOutDatumByValue ScriptDataOrFile
sDataOrFile -> do
      HashableScriptData
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
      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 -> HashableScriptData -> TxOutDatum CtxTx era
forall era.
AlonzoEraOnwards era -> HashableScriptData -> TxOutDatum CtxTx era
TxOutSupplementalDatum AlonzoEraOnwards era
supp HashableScriptData
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
        HashableScriptData
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
        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 -> RIO e (TxOutDatum CtxTx era))
-> TxOutDatum CtxTx era -> RIO e (TxOutDatum CtxTx era)
forall a b. (a -> b) -> a -> b
$ BabbageEraOnwards era -> HashableScriptData -> TxOutDatum CtxTx era
forall era ctx.
BabbageEraOnwards era -> HashableScriptData -> TxOutDatum ctx era
TxOutDatumInline BabbageEraOnwards era
babbageOnwards HashableScriptData
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 a ann. Pretty a => a -> Doc ann
forall ann. Text -> 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