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

module Cardano.CLI.Type.Error.TxValidationError
  ( TxAuxScriptsValidationError (..)
  , TxGovDuplicateVotes (..)
  , validateScriptSupportedInEra
  , validateTxAuxScripts
  , validateRequiredSigners
  , validateTxReturnCollateral
  , validateTxScriptValidity
  , validateTxTotalCollateral
  , validateTxValidityLowerBound
  , validateTxCurrentTreasuryValue
  , validateTxTreasuryDonation
  )
where

import Cardano.Api
import Cardano.Api.Experimental
import Cardano.Api.Experimental qualified as Exp

import Cardano.CLI.Orphan ()
import Cardano.CLI.Type.Common

import Prelude

import Data.Bifunctor (first)
import Prettyprinter (viaShow)

data ScriptLanguageValidationError
  = ScriptLanguageValidationError AnyScriptLanguage AnyCardanoEra
  deriving Int -> ScriptLanguageValidationError -> ShowS
[ScriptLanguageValidationError] -> ShowS
ScriptLanguageValidationError -> String
(Int -> ScriptLanguageValidationError -> ShowS)
-> (ScriptLanguageValidationError -> String)
-> ([ScriptLanguageValidationError] -> ShowS)
-> Show ScriptLanguageValidationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScriptLanguageValidationError -> ShowS
showsPrec :: Int -> ScriptLanguageValidationError -> ShowS
$cshow :: ScriptLanguageValidationError -> String
show :: ScriptLanguageValidationError -> String
$cshowList :: [ScriptLanguageValidationError] -> ShowS
showList :: [ScriptLanguageValidationError] -> ShowS
Show

instance Error ScriptLanguageValidationError where
  prettyError :: forall ann. ScriptLanguageValidationError -> Doc ann
prettyError = \case
    ScriptLanguageValidationError AnyScriptLanguage
lang AnyCardanoEra
era ->
      Doc ann
"The script language "
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> AnyScriptLanguage -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow AnyScriptLanguage
lang
        Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" is not supported in 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."

validateScriptSupportedInEra
  :: IsEra era
  => ScriptInAnyLang
  -> Either ScriptLanguageValidationError (ScriptInEra era)
validateScriptSupportedInEra :: forall era.
IsEra era =>
ScriptInAnyLang
-> Either ScriptLanguageValidationError (ScriptInEra era)
validateScriptSupportedInEra script :: ScriptInAnyLang
script@(ScriptInAnyLang ScriptLanguage lang
lang Script lang
_) =
  let era :: ShelleyBasedEra era
era = Era era -> ShelleyBasedEra era
forall era. Era era -> ShelleyBasedEra era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert Era era
forall era. IsEra era => Era era
useEra
   in case ShelleyBasedEra era -> ScriptInAnyLang -> Maybe (ScriptInEra era)
forall era.
ShelleyBasedEra era -> ScriptInAnyLang -> Maybe (ScriptInEra era)
toScriptInEra ShelleyBasedEra era
era ScriptInAnyLang
script of
        Maybe (ScriptInEra era)
Nothing ->
          ScriptLanguageValidationError
-> Either ScriptLanguageValidationError (ScriptInEra era)
forall a b. a -> Either a b
Left (ScriptLanguageValidationError
 -> Either ScriptLanguageValidationError (ScriptInEra era))
-> ScriptLanguageValidationError
-> Either ScriptLanguageValidationError (ScriptInEra era)
forall a b. (a -> b) -> a -> b
$
            AnyScriptLanguage -> AnyCardanoEra -> ScriptLanguageValidationError
ScriptLanguageValidationError
              (ScriptLanguage lang -> AnyScriptLanguage
forall lang. ScriptLanguage lang -> AnyScriptLanguage
AnyScriptLanguage ScriptLanguage lang
lang)
              (CardanoEra era -> AnyCardanoEra
forall era. CardanoEra era -> AnyCardanoEra
anyCardanoEra (CardanoEra era -> AnyCardanoEra)
-> CardanoEra era -> AnyCardanoEra
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era -> CardanoEra era
forall era. ShelleyBasedEra era -> CardanoEra era
forall (eon :: * -> *) era.
ToCardanoEra eon =>
eon era -> CardanoEra era
toCardanoEra ShelleyBasedEra era
era)
        Just ScriptInEra era
script' -> ScriptInEra era
-> Either ScriptLanguageValidationError (ScriptInEra era)
forall a. a -> Either ScriptLanguageValidationError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptInEra era
script'

validateTxTotalCollateral
  :: IsEra era
  => Maybe Lovelace
  -> TxTotalCollateral era
validateTxTotalCollateral :: forall era. IsEra era => Maybe Lovelace -> TxTotalCollateral era
validateTxTotalCollateral Maybe Lovelace
Nothing = TxTotalCollateral era
forall era. TxTotalCollateral era
TxTotalCollateralNone
validateTxTotalCollateral (Just Lovelace
coll) = do
  BabbageEraOnwards era -> Lovelace -> TxTotalCollateral era
forall era.
BabbageEraOnwards era -> Lovelace -> TxTotalCollateral era
TxTotalCollateral (Era era -> BabbageEraOnwards era
forall era. Era era -> BabbageEraOnwards era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert Era era
forall era. IsEra era => Era era
useEra) Lovelace
coll

validateTxCurrentTreasuryValue
  :: forall era
   . Exp.IsEra era
  => Maybe TxCurrentTreasuryValue
  -> Maybe (Featured ConwayEraOnwards era (Maybe Lovelace))
validateTxCurrentTreasuryValue :: forall era.
IsEra era =>
Maybe TxCurrentTreasuryValue
-> Maybe (Featured ConwayEraOnwards era (Maybe Lovelace))
validateTxCurrentTreasuryValue Maybe TxCurrentTreasuryValue
mCurrentTreasuryValue = do
  TxCurrentTreasuryValue{Lovelace
unTxCurrentTreasuryValue :: Lovelace
unTxCurrentTreasuryValue :: TxCurrentTreasuryValue -> Lovelace
unTxCurrentTreasuryValue} <- Maybe TxCurrentTreasuryValue
mCurrentTreasuryValue
  Era era
-> (EraCommonConstraints era =>
    Maybe (Featured ConwayEraOnwards era (Maybe Lovelace)))
-> Maybe (Featured ConwayEraOnwards era (Maybe Lovelace))
forall era a. Era era -> (EraCommonConstraints era => a) -> a
obtainCommonConstraints (forall era. IsEra era => Era era
Exp.useEra @era) ((EraCommonConstraints era =>
  Maybe (Featured ConwayEraOnwards era (Maybe Lovelace)))
 -> Maybe (Featured ConwayEraOnwards era (Maybe Lovelace)))
-> (EraCommonConstraints era =>
    Maybe (Featured ConwayEraOnwards era (Maybe Lovelace)))
-> Maybe (Featured ConwayEraOnwards era (Maybe Lovelace))
forall a b. (a -> b) -> a -> b
$ Maybe Lovelace
-> Maybe (Featured ConwayEraOnwards era (Maybe Lovelace))
forall (eon :: * -> *) era a.
(IsCardanoEra era, Eon eon) =>
a -> Maybe (Featured eon era a)
mkFeatured (Maybe Lovelace
 -> Maybe (Featured ConwayEraOnwards era (Maybe Lovelace)))
-> Maybe Lovelace
-> Maybe (Featured ConwayEraOnwards era (Maybe Lovelace))
forall a b. (a -> b) -> a -> b
$ Lovelace -> Maybe Lovelace
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Lovelace
unTxCurrentTreasuryValue

validateTxTreasuryDonation
  :: forall era
   . Exp.IsEra era
  => Maybe TxTreasuryDonation
  -> Maybe (Featured ConwayEraOnwards era Lovelace)
validateTxTreasuryDonation :: forall era.
IsEra era =>
Maybe TxTreasuryDonation
-> Maybe (Featured ConwayEraOnwards era Lovelace)
validateTxTreasuryDonation Maybe TxTreasuryDonation
mTreasuryDonation = do
  TxTreasuryDonation{Lovelace
unTxTreasuryDonation :: Lovelace
unTxTreasuryDonation :: TxTreasuryDonation -> Lovelace
unTxTreasuryDonation} <- Maybe TxTreasuryDonation
mTreasuryDonation

  Era era
-> (EraCommonConstraints era =>
    Maybe (Featured ConwayEraOnwards era Lovelace))
-> Maybe (Featured ConwayEraOnwards era Lovelace)
forall era a. Era era -> (EraCommonConstraints era => a) -> a
Exp.obtainCommonConstraints (forall era. IsEra era => Era era
Exp.useEra @era) ((EraCommonConstraints era =>
  Maybe (Featured ConwayEraOnwards era Lovelace))
 -> Maybe (Featured ConwayEraOnwards era Lovelace))
-> (EraCommonConstraints era =>
    Maybe (Featured ConwayEraOnwards era Lovelace))
-> Maybe (Featured ConwayEraOnwards era Lovelace)
forall a b. (a -> b) -> a -> b
$ Lovelace -> Maybe (Featured ConwayEraOnwards era Lovelace)
forall (eon :: * -> *) era a.
(IsCardanoEra era, Eon eon) =>
a -> Maybe (Featured eon era a)
mkFeatured Lovelace
unTxTreasuryDonation

validateTxReturnCollateral
  :: IsEra era
  => Maybe (TxOut CtxTx era)
  -> TxReturnCollateral CtxTx era
validateTxReturnCollateral :: forall era.
IsEra era =>
Maybe (TxOut CtxTx era) -> TxReturnCollateral CtxTx era
validateTxReturnCollateral Maybe (TxOut CtxTx era)
Nothing = TxReturnCollateral CtxTx era
forall ctx era. TxReturnCollateral ctx era
TxReturnCollateralNone
validateTxReturnCollateral (Just TxOut CtxTx era
retColTxOut) = do
  BabbageEraOnwards era
-> TxOut CtxTx era -> TxReturnCollateral CtxTx era
forall era ctx.
BabbageEraOnwards era
-> TxOut ctx era -> TxReturnCollateral ctx era
TxReturnCollateral (Era era -> BabbageEraOnwards era
forall era. Era era -> BabbageEraOnwards era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert Era era
forall era. IsEra era => Era era
useEra) TxOut CtxTx era
retColTxOut

validateTxValidityLowerBound
  :: IsEra era
  => Maybe SlotNo
  -> TxValidityLowerBound era
validateTxValidityLowerBound :: forall era. IsEra era => Maybe SlotNo -> TxValidityLowerBound era
validateTxValidityLowerBound Maybe SlotNo
Nothing = TxValidityLowerBound era
forall era. TxValidityLowerBound era
TxValidityNoLowerBound
validateTxValidityLowerBound (Just SlotNo
slot) = do
  AllegraEraOnwards era -> SlotNo -> TxValidityLowerBound era
forall era.
AllegraEraOnwards era -> SlotNo -> TxValidityLowerBound era
TxValidityLowerBound (Era era -> AllegraEraOnwards era
forall era. Era era -> AllegraEraOnwards era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert Era era
forall era. IsEra era => Era era
useEra) SlotNo
slot

newtype TxAuxScriptsValidationError
  = TxAuxScriptsLanguageError ScriptLanguageValidationError
  deriving Int -> TxAuxScriptsValidationError -> ShowS
[TxAuxScriptsValidationError] -> ShowS
TxAuxScriptsValidationError -> String
(Int -> TxAuxScriptsValidationError -> ShowS)
-> (TxAuxScriptsValidationError -> String)
-> ([TxAuxScriptsValidationError] -> ShowS)
-> Show TxAuxScriptsValidationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TxAuxScriptsValidationError -> ShowS
showsPrec :: Int -> TxAuxScriptsValidationError -> ShowS
$cshow :: TxAuxScriptsValidationError -> String
show :: TxAuxScriptsValidationError -> String
$cshowList :: [TxAuxScriptsValidationError] -> ShowS
showList :: [TxAuxScriptsValidationError] -> ShowS
Show

instance Error TxAuxScriptsValidationError where
  prettyError :: forall ann. TxAuxScriptsValidationError -> Doc ann
prettyError (TxAuxScriptsLanguageError ScriptLanguageValidationError
e) =
    Doc ann
"Transaction auxiliary scripts error: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> ScriptLanguageValidationError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. ScriptLanguageValidationError -> Doc ann
prettyError ScriptLanguageValidationError
e

validateTxAuxScripts
  :: IsEra era
  => [ScriptInAnyLang]
  -> Either TxAuxScriptsValidationError (TxAuxScripts era)
validateTxAuxScripts :: forall era.
IsEra era =>
[ScriptInAnyLang]
-> Either TxAuxScriptsValidationError (TxAuxScripts era)
validateTxAuxScripts [] = TxAuxScripts era
-> Either TxAuxScriptsValidationError (TxAuxScripts era)
forall a. a -> Either TxAuxScriptsValidationError a
forall (m :: * -> *) a. Monad m => a -> m a
return TxAuxScripts era
forall era. TxAuxScripts era
TxAuxScriptsNone
validateTxAuxScripts [ScriptInAnyLang]
scripts = do
  [ScriptInEra era]
scriptsInEra <-
    (ScriptInAnyLang
 -> Either TxAuxScriptsValidationError (ScriptInEra era))
-> [ScriptInAnyLang]
-> Either TxAuxScriptsValidationError [ScriptInEra era]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((ScriptLanguageValidationError -> TxAuxScriptsValidationError)
-> Either ScriptLanguageValidationError (ScriptInEra era)
-> Either TxAuxScriptsValidationError (ScriptInEra era)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ScriptLanguageValidationError -> TxAuxScriptsValidationError
TxAuxScriptsLanguageError (Either ScriptLanguageValidationError (ScriptInEra era)
 -> Either TxAuxScriptsValidationError (ScriptInEra era))
-> (ScriptInAnyLang
    -> Either ScriptLanguageValidationError (ScriptInEra era))
-> ScriptInAnyLang
-> Either TxAuxScriptsValidationError (ScriptInEra era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptInAnyLang
-> Either ScriptLanguageValidationError (ScriptInEra era)
forall era.
IsEra era =>
ScriptInAnyLang
-> Either ScriptLanguageValidationError (ScriptInEra era)
validateScriptSupportedInEra) [ScriptInAnyLang]
scripts
  TxAuxScripts era
-> Either TxAuxScriptsValidationError (TxAuxScripts era)
forall a. a -> Either TxAuxScriptsValidationError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TxAuxScripts era
 -> Either TxAuxScriptsValidationError (TxAuxScripts era))
-> TxAuxScripts era
-> Either TxAuxScriptsValidationError (TxAuxScripts era)
forall a b. (a -> b) -> a -> b
$ AllegraEraOnwards era -> [ScriptInEra era] -> TxAuxScripts era
forall era.
AllegraEraOnwards era -> [ScriptInEra era] -> TxAuxScripts era
TxAuxScripts (Era era -> AllegraEraOnwards era
forall era. Era era -> AllegraEraOnwards era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert Era era
forall era. IsEra era => Era era
useEra) [ScriptInEra era]
scriptsInEra

validateRequiredSigners
  :: IsEra era
  => [Hash PaymentKey]
  -> TxExtraKeyWitnesses era
validateRequiredSigners :: forall era.
IsEra era =>
[Hash PaymentKey] -> TxExtraKeyWitnesses era
validateRequiredSigners [] = TxExtraKeyWitnesses era
forall era. TxExtraKeyWitnesses era
TxExtraKeyWitnessesNone
validateRequiredSigners [Hash PaymentKey]
reqSigs = do
  AlonzoEraOnwards era
-> [Hash PaymentKey] -> TxExtraKeyWitnesses era
forall era.
AlonzoEraOnwards era
-> [Hash PaymentKey] -> TxExtraKeyWitnesses era
TxExtraKeyWitnesses (Era era -> AlonzoEraOnwards era
forall era. Era era -> AlonzoEraOnwards era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert Era era
forall era. IsEra era => Era era
useEra) [Hash PaymentKey]
reqSigs

validateTxScriptValidity
  :: IsEra era
  => Maybe ScriptValidity
  -> TxScriptValidity era
validateTxScriptValidity :: forall era.
IsEra era =>
Maybe ScriptValidity -> TxScriptValidity era
validateTxScriptValidity Maybe ScriptValidity
Nothing = TxScriptValidity era
forall era. TxScriptValidity era
TxScriptValidityNone
validateTxScriptValidity (Just ScriptValidity
scriptValidity) = do
  AlonzoEraOnwards era -> ScriptValidity -> TxScriptValidity era
forall era.
AlonzoEraOnwards era -> ScriptValidity -> TxScriptValidity era
TxScriptValidity (Era era -> AlonzoEraOnwards era
forall era. Era era -> AlonzoEraOnwards era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert Era era
forall era. IsEra era => Era era
useEra) ScriptValidity
scriptValidity

newtype TxGovDuplicateVotes era
  = TxGovDuplicateVotes (VotesMergingConflict era)

instance Error (TxGovDuplicateVotes era) where
  prettyError :: forall ann. TxGovDuplicateVotes era -> Doc ann
prettyError (TxGovDuplicateVotes (VotesMergingConflict (Voter
_voter, [GovActionId]
actionIds))) =
    Doc ann
"Trying to merge votes with similar action identifiers: "
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [GovActionId] -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow [GovActionId]
actionIds
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
". This would cause ignoring some of the votes, so not proceeding."