{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.CLI.Type.Error.TxCmdError
  ( TxCmdError (..)
  , AnyTxBodyErrorAutoBalance (..)
  , renderTxCmdError
  )
where

import Cardano.Api
import Cardano.Api.Byron (GenesisDataError)
import Cardano.Api.Experimental qualified as Exp
import Cardano.Api.Ledger qualified as L

import Cardano.CLI.Read
import Cardano.CLI.Type.Common
import Cardano.CLI.Type.Error.BootstrapWitnessError
import Cardano.CLI.Type.Error.HashCmdError (HashCheckError)
import Cardano.CLI.Type.Error.NodeEraMismatchError
import Cardano.CLI.Type.Error.NodeEraMismatchError qualified as NEM
import Cardano.CLI.Type.Error.ProtocolParamsError
import Cardano.CLI.Type.Error.TxValidationError
import Cardano.CLI.Type.Output
import Cardano.Prelude qualified as List

import RIO

import Data.Text.Lazy.Builder (toLazyText)
import Formatting.Buildable (Buildable (build))

data AnyTxBodyErrorAutoBalance where
  AnyTxBodyErrorAutoBalance :: TxBodyErrorAutoBalance era -> AnyTxBodyErrorAutoBalance

data TxCmdError
  = TxCmdProtocolParamsError ProtocolParamsError
  | TxCmdReadWitnessSigningDataError !ReadWitnessSigningDataError
  | TxCmdWriteFileError !(FileError ())
  | TxCmdBootstrapWitnessError !BootstrapWitnessError
  | TxCmdTxSubmitError !Text
  | TxCmdTxSubmitErrorEraMismatch !EraMismatch
  | TxCmdTxBodyError !TxBodyError
  | TxCmdWitnessEraMismatch !AnyCardanoEra !AnyCardanoEra !WitnessFile
  | TxCmdPolicyIdsMissing ![PolicyId] ![PolicyId]
  | -- The first list is the missing policy Ids, the second list is the
    -- policy Ids that were provided in the transaction.
    TxCmdPolicyIdsExcess ![PolicyId]
  | TxCmdBalanceTxBody !AnyTxBodyErrorAutoBalance
  | TxCmdTxInsDoNotExist !TxInsExistError
  | TxCmdTextEnvError !(FileError TextEnvelopeError)
  | TxCmdPlutusScriptCostErr !PlutusScriptCostError
  | TxCmdPParamExecutionUnitsNotAvailable
  | TxCmdProtocolParametersNotPresentInTxBody
  | TxCmdTxNodeEraMismatchError !NodeEraMismatchError
  | TxCmdQueryConvenienceError !QueryConvenienceError
  | TxCmdQueryNotScriptLocked !ScriptLockedTxInsError
  | TxCmdScriptDataError !ScriptDataError
  | -- Validation errors
    forall era. TxCmdTxGovDuplicateVotes (TxGovDuplicateVotes era)
  | forall era. TxCmdFeeEstimationError (TxFeeEstimationError era)
  | TxCmdPoolMetadataHashError AnchorDataFromCertificateError
  | TxCmdHashCheckError L.Url HashCheckError
  | TxCmdUnregisteredStakeAddress !(Set StakeCredential)
  | forall era. TxCmdAlonzoEraOnwardsRequired !(CardanoEra era)
  | TxCmdUtxoFileError !(FileError JsonDecodeError)
  | TxCmdUtxoJsonError String
  | forall era. TxCmdDeprecatedEra (Exp.DeprecatedEra era)
  | TxCmdGenesisDataError GenesisDataError

instance Show TxCmdError where
  show :: TxCmdError -> String
show = Doc Any -> String
forall a. Show a => a -> String
show (Doc Any -> String)
-> (TxCmdError -> Doc Any) -> TxCmdError -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxCmdError -> Doc Any
forall ann. TxCmdError -> Doc ann
renderTxCmdError

instance Error TxCmdError where
  prettyError :: forall ann. TxCmdError -> Doc ann
prettyError = TxCmdError -> Doc ann
forall ann. TxCmdError -> Doc ann
renderTxCmdError

renderTxCmdError :: TxCmdError -> Doc ann
renderTxCmdError :: forall ann. TxCmdError -> Doc ann
renderTxCmdError = \case
  TxCmdReadWitnessSigningDataError ReadWitnessSigningDataError
witSignDataErr ->
    ReadWitnessSigningDataError -> Doc ann
forall ann. ReadWitnessSigningDataError -> Doc ann
renderReadWitnessSigningDataError ReadWitnessSigningDataError
witSignDataErr
  TxCmdWriteFileError FileError ()
fileErr ->
    FileError () -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. FileError () -> Doc ann
prettyError FileError ()
fileErr
  TxCmdTxSubmitError Text
res ->
    Doc ann
"Error while submitting tx: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
pretty Text
res
  TxCmdTxSubmitErrorEraMismatch EraMismatch{Text
ledgerEraName :: Text
ledgerEraName :: EraMismatch -> Text
ledgerEraName, Text
otherEraName :: Text
otherEraName :: EraMismatch -> Text
otherEraName} ->
    Doc ann
"The era of the node and the tx do not match. "
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"The node is running in the "
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
pretty Text
ledgerEraName
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" era, but the transaction is for the "
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
pretty Text
otherEraName
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" era."
  TxCmdBootstrapWitnessError BootstrapWitnessError
sbwErr ->
    BootstrapWitnessError -> Doc ann
forall ann. BootstrapWitnessError -> Doc ann
renderBootstrapWitnessError BootstrapWitnessError
sbwErr
  TxCmdTxBodyError TxBodyError
err' ->
    Doc ann
"Transaction validaton error: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> TxBodyError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. TxBodyError -> Doc ann
prettyError TxBodyError
err'
  TxCmdWitnessEraMismatch AnyCardanoEra
era AnyCardanoEra
era' (WitnessFile String
file) ->
    Doc ann
"The era of a witness does not match the era of the transaction. "
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"The transaction is for the "
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> AnyCardanoEra -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. AnyCardanoEra -> Doc ann
pretty AnyCardanoEra
era
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" era, but the "
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"witness in "
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow String
file
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" is for the "
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> AnyCardanoEra -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. AnyCardanoEra -> Doc ann
pretty AnyCardanoEra
era'
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" era."
  TxCmdPolicyIdsMissing [PolicyId]
missingPolicyIds [PolicyId]
knownPolicyIds ->
    [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat ([Doc ann] -> Doc ann) -> [Doc ann] -> Doc ann
forall a b. (a -> b) -> a -> b
$
      [ Doc ann
"The \"--mint\" flag specifies an asset with a policy Id, but no "
      , Doc ann
"corresponding monetary policy script has been provided as a witness "
      , Doc ann
"(via the \"--mint-script-file\" flag). The policy Id in question is: "
      , [PolicyId] -> Doc ann
forall ann. [PolicyId] -> Doc ann
prettyPolicyIdList [PolicyId]
missingPolicyIds
      ]
        [Doc ann] -> [Doc ann] -> [Doc ann]
forall a. Semigroup a => a -> a -> a
<> [Doc ann
". Known policy Ids are: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [PolicyId] -> Doc ann
forall ann. [PolicyId] -> Doc ann
prettyPolicyIdList [PolicyId]
knownPolicyIds | Bool -> Bool
not ([PolicyId] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PolicyId]
knownPolicyIds)]
  TxCmdPolicyIdsExcess [PolicyId]
policyids ->
    [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
      [ Doc ann
"A script provided to witness minting does not correspond to the policy "
      , Doc ann
"id of any asset specified in the \"--mint\" field. The script hash is: "
      , [PolicyId] -> Doc ann
forall ann. [PolicyId] -> Doc ann
prettyPolicyIdList [PolicyId]
policyids
      ]
  TxCmdBalanceTxBody (AnyTxBodyErrorAutoBalance TxBodyErrorAutoBalance era
err') ->
    TxBodyErrorAutoBalance era -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. TxBodyErrorAutoBalance era -> Doc ann
prettyError TxBodyErrorAutoBalance era
err'
  TxCmdTxInsDoNotExist TxInsExistError
e ->
    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
$ TxInsExistError -> Text
renderTxInsExistError TxInsExistError
e
  TxCmdTextEnvError FileError TextEnvelopeError
err' ->
    [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
      [ Doc ann
"Failed to decode the ledger's CDDL serialisation format. "
      , Doc ann
"File error: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> FileError TextEnvelopeError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. FileError TextEnvelopeError -> Doc ann
prettyError FileError TextEnvelopeError
err'
      ]
  TxCmdPlutusScriptCostErr PlutusScriptCostError
err' ->
    PlutusScriptCostError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. PlutusScriptCostError -> Doc ann
prettyError PlutusScriptCostError
err'
  TxCmdError
TxCmdPParamExecutionUnitsNotAvailable ->
    [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
      [ Doc ann
"Execution units not available in the protocol parameters. This is "
      , Doc ann
"likely due to not being in the Alonzo era"
      ]
  TxCmdTxNodeEraMismatchError (NodeEraMismatchError{era :: ()
NEM.era = CardanoEra era
valueEra, nodeEra :: ()
nodeEra = CardanoEra nodeEra
nodeEra}) ->
    CardanoEra nodeEra
-> (CardanoEraConstraints nodeEra => Doc ann) -> Doc ann
forall era a.
CardanoEra era -> (CardanoEraConstraints era => a) -> a
cardanoEraConstraints CardanoEra nodeEra
nodeEra ((CardanoEraConstraints nodeEra => Doc ann) -> Doc ann)
-> (CardanoEraConstraints nodeEra => Doc ann) -> Doc ann
forall a b. (a -> b) -> a -> b
$
      CardanoEra era -> (CardanoEraConstraints era => Doc ann) -> Doc ann
forall era a.
CardanoEra era -> (CardanoEraConstraints era => a) -> a
cardanoEraConstraints CardanoEra era
valueEra ((CardanoEraConstraints era => Doc ann) -> Doc ann)
-> (CardanoEraConstraints era => Doc ann) -> Doc ann
forall a b. (a -> b) -> a -> b
$
        [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat
          [ Doc ann
"Transactions can only be produced in the same era as the node. Requested era: "
          , CardanoEra era -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. CardanoEra era -> Doc ann
pretty CardanoEra era
valueEra Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
", node era: "
          , CardanoEra nodeEra -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. CardanoEra nodeEra -> Doc ann
pretty CardanoEra nodeEra
nodeEra Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"."
          ]
  TxCmdQueryConvenienceError QueryConvenienceError
e ->
    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
$ QueryConvenienceError -> Text
renderQueryConvenienceError QueryConvenienceError
e
  TxCmdQueryNotScriptLocked ScriptLockedTxInsError
e ->
    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
$ ScriptLockedTxInsError -> Text
renderNotScriptLockedTxInsError ScriptLockedTxInsError
e
  TxCmdError
TxCmdProtocolParametersNotPresentInTxBody ->
    Doc ann
"Protocol parameters were not found in transaction body"
  TxCmdScriptDataError ScriptDataError
e ->
    ScriptDataError -> Doc ann
forall ann. ScriptDataError -> Doc ann
renderScriptDataError ScriptDataError
e
  TxCmdProtocolParamsError ProtocolParamsError
e ->
    ProtocolParamsError -> Doc ann
forall ann. ProtocolParamsError -> Doc ann
renderProtocolParamsError ProtocolParamsError
e
  -- Validation errors
  TxCmdTxGovDuplicateVotes TxGovDuplicateVotes era
e ->
    TxGovDuplicateVotes era -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. TxGovDuplicateVotes era -> Doc ann
prettyError TxGovDuplicateVotes era
e
  TxCmdFeeEstimationError TxFeeEstimationError era
e ->
    TxFeeEstimationError era -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. TxFeeEstimationError era -> Doc ann
prettyError TxFeeEstimationError era
e
  TxCmdPoolMetadataHashError AnchorDataFromCertificateError
e ->
    Doc ann
"Hash of the pool metadata hash is not valid:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnchorDataFromCertificateError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. AnchorDataFromCertificateError -> Doc ann
prettyError AnchorDataFromCertificateError
e
  TxCmdHashCheckError Url
url HashCheckError
e ->
    Doc ann
"Hash of the file is not valid. Url:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
pretty (Url -> Text
L.urlToText Url
url) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> HashCheckError -> Doc ann
forall a ann. Exception a => a -> Doc ann
prettyException HashCheckError
e
  TxCmdUnregisteredStakeAddress Set StakeCredential
credentials ->
    Doc ann
"Stake credential specified in the proposal is not registered on-chain:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Set StakeCredential -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow Set StakeCredential
credentials
  TxCmdAlonzoEraOnwardsRequired CardanoEra era
era ->
    Doc ann
"This command is only available in the Alonzo era and onwards, since earlier eras do not support scripting. Era requested ("
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> CardanoEra era -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. CardanoEra era -> Doc ann
pretty CardanoEra era
era
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
") is not supported."
  TxCmdUtxoFileError FileError JsonDecodeError
e ->
    Doc ann
"Error while reading UTxO set from JSON file: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> FileError JsonDecodeError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. FileError JsonDecodeError -> Doc ann
prettyError FileError JsonDecodeError
e
  TxCmdDeprecatedEra DeprecatedEra era
e -> DeprecatedEra era -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. DeprecatedEra era -> Doc ann
pretty DeprecatedEra era
e
  TxCmdUtxoJsonError String
e ->
    Doc ann
"Error while decoding JSON from UTxO set file: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> String -> Doc ann
forall ann. String -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty String
e
  TxCmdGenesisDataError GenesisDataError
genesisDataError ->
    Doc ann
"Error while reading Byron genesis data: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow (Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ GenesisDataError -> Builder
forall p. Buildable p => p -> Builder
build GenesisDataError
genesisDataError)

prettyPolicyIdList :: [PolicyId] -> Doc ann
prettyPolicyIdList :: forall ann. [PolicyId] -> Doc ann
prettyPolicyIdList =
  [Doc ann] -> Doc ann
forall a. Monoid a => [a] -> a
mconcat ([Doc ann] -> Doc ann)
-> ([PolicyId] -> [Doc ann]) -> [PolicyId] -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc ann -> [Doc ann] -> [Doc ann]
forall a. a -> [a] -> [a]
List.intersperse Doc ann
", " ([Doc ann] -> [Doc ann])
-> ([PolicyId] -> [Doc ann]) -> [PolicyId] -> [Doc ann]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PolicyId -> Doc ann) -> [PolicyId] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
pretty (Text -> Doc ann) -> (PolicyId -> Text) -> PolicyId -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PolicyId -> Text
forall a. SerialiseAsRawBytes a => a -> Text
serialiseToRawBytesHexText)