diff --git a/cardano-api/cardano-api.cabal b/cardano-api/cardano-api.cabal index c2c77d1787..446fb12c67 100644 --- a/cardano-api/cardano-api.cabal +++ b/cardano-api/cardano-api.cabal @@ -131,6 +131,7 @@ library internal Cardano.Api.Utils Cardano.Api.Value Cardano.Api.ValueParser + Cardano.Api.Via.ShowOf -- TODO: Eliminate in the future when -- we create wrapper types for the ledger types -- in this module diff --git a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs index c2fb04c934..716e2f1423 100644 --- a/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs +++ b/cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs @@ -47,6 +47,7 @@ import qualified Cardano.Ledger.BaseTypes as L import Cardano.Ledger.Binary (FromCBOR) import qualified Cardano.Ledger.Core as L import qualified Cardano.Ledger.SafeHash as L +import qualified Cardano.Ledger.Shelley.Rules as L import qualified Cardano.Ledger.UTxO as L import qualified Ouroboros.Consensus.Protocol.Abstract as Consensus import qualified Ouroboros.Consensus.Protocol.Praos.Common as Consensus @@ -213,6 +214,8 @@ type ShelleyBasedEraConstraints era = , IsCardanoEra era , IsShelleyBasedEra era , ToJSON (Consensus.ChainDepState (ConsensusProtocol era)) + , ToJSON (L.PredicateFailure (L.EraRule "LEDGER" (ShelleyLedgerEra era))) + , ToJSON (L.PredicateFailure (L.EraRule "UTXOW" (ShelleyLedgerEra era))) , Typeable era ) diff --git a/cardano-api/internal/Cardano/Api/InMode.hs b/cardano-api/internal/Cardano/Api/InMode.hs index 499cfe2213..c8a640cc84 100644 --- a/cardano-api/internal/Cardano/Api/InMode.hs +++ b/cardano-api/internal/Cardano/Api/InMode.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -30,6 +31,7 @@ import Cardano.Api.Eon.ByronEraOnly import Cardano.Api.Eon.ShelleyBasedEra import Cardano.Api.Eras import Cardano.Api.Modes +import Cardano.Api.Orphans () import Cardano.Api.Tx import Cardano.Api.TxBody @@ -43,8 +45,11 @@ import qualified Ouroboros.Consensus.Shelley.HFEras as Consensus import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus import qualified Ouroboros.Consensus.TypeFamilyWrappers as Consensus +import Data.Aeson (ToJSON (..), (.=)) +import qualified Data.Aeson as Aeson import Data.SOP.Strict (NS (S, Z)) - +import qualified Data.Text as Text +import GHC.Generics -- ---------------------------------------------------------------------------- -- Transactions in the context of a consensus mode @@ -219,59 +224,54 @@ toConsensusTxId (TxIdInMode ConwayEra txid) = -- transaction to a local node. The errors are specific to an era. -- data TxValidationError era where + ByronTxValidationError + :: Consensus.ApplyTxErr Consensus.ByronBlock + -> TxValidationError era - ByronTxValidationError - :: Consensus.ApplyTxErr Consensus.ByronBlock - -> TxValidationError ByronEra + ShelleyTxValidationError + :: ShelleyBasedEra era + -> Consensus.ApplyTxErr (Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)) + -> TxValidationError era - ShelleyTxValidationError - :: ShelleyBasedEra era - -> Consensus.ApplyTxErr (Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)) - -> TxValidationError era +deriving instance Generic (TxValidationError era) --- The GADT in the ShelleyTxValidationError case requires a custom instance instance Show (TxValidationError era) where - showsPrec p (ByronTxValidationError err) = + showsPrec p = \case + ByronTxValidationError err -> showParen (p >= 11) ( showString "ByronTxValidationError " . showsPrec 11 err ) - showsPrec p (ShelleyTxValidationError ShelleyBasedEraShelley err) = - showParen (p >= 11) - ( showString "ShelleyTxValidationError ShelleyBasedEraShelley " - . showsPrec 11 err - ) - - showsPrec p (ShelleyTxValidationError ShelleyBasedEraAllegra err) = - showParen (p >= 11) - ( showString "ShelleyTxValidationError ShelleyBasedEraAllegra " - . showsPrec 11 err - ) - - showsPrec p (ShelleyTxValidationError ShelleyBasedEraMary err) = - showParen (p >= 11) - ( showString "ShelleyTxValidationError ShelleyBasedEraMary " - . showsPrec 11 err - ) - - showsPrec p (ShelleyTxValidationError ShelleyBasedEraAlonzo err) = - showParen (p >= 11) - ( showString "ShelleyTxValidationError ShelleyBasedEraAlonzo " - . showsPrec 11 err - ) - - showsPrec p (ShelleyTxValidationError ShelleyBasedEraBabbage err) = - showParen (p >= 11) - ( showString "ShelleyTxValidationError ShelleyBasedEraBabbage " - . showsPrec 11 err - ) - - showsPrec p (ShelleyTxValidationError ShelleyBasedEraConway err) = - showParen (p >= 11) - ( showString "ShelleyTxValidationError ShelleyBasedEraConway " - . showsPrec 11 err - ) + ShelleyTxValidationError sbe err -> + shelleyBasedEraConstraints sbe $ + showParen (p >= 11) + ( showString "ShelleyTxValidationError " + . showString (show sbe) + . showString " " + . showsPrec 11 err + ) + +instance ToJSON (TxValidationError era) where + toJSON = \case + ByronTxValidationError err -> + Aeson.object + [ "kind" .= Aeson.String "ByronTxValidationError" + , "error" .= toJSON err + ] + ShelleyTxValidationError sbe err -> + shelleyBasedEraConstraints sbe $ + Aeson.object + [ "kind" .= Aeson.String "ShelleyTxValidationError" + , "era" .= toJSON (Text.pack (show sbe)) + , "error" .= appTxErrToJson sbe err + ] + +appTxErrToJson :: () + => ShelleyBasedEra era + -> Consensus.ApplyTxErr (Consensus.ShelleyBlock (ConsensusProtocol era) (ShelleyLedgerEra era)) + -> Aeson.Value +appTxErrToJson w e = shelleyBasedEraConstraints w $ toJSON e -- | A 'TxValidationError' in one of the eras supported by a given protocol -- mode. diff --git a/cardano-api/internal/Cardano/Api/Orphans.hs b/cardano-api/internal/Cardano/Api/Orphans.hs index 176a02e5f7..98785b01f0 100644 --- a/cardano-api/internal/Cardano/Api/Orphans.hs +++ b/cardano-api/internal/Cardano/Api/Orphans.hs @@ -1,7 +1,8 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -11,23 +12,55 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-orphans -Wno-unused-imports #-} module Cardano.Api.Orphans () where +import Cardano.Api.Via.ShowOf + import Cardano.Binary (DecoderError (..)) +import qualified Cardano.Chain.Byron.API as L +import qualified Cardano.Chain.Common as L +import qualified Cardano.Chain.Delegation.Validation.Scheduling as L.Scheduling +import qualified Cardano.Chain.Update as L +import qualified Cardano.Chain.Update.Validation.Endorsement as L.Endorsement +import qualified Cardano.Chain.Update.Validation.Interface as L.Interface +import qualified Cardano.Chain.Update.Validation.Registration as L.Registration +import qualified Cardano.Chain.Update.Validation.Voting as L.Voting +import qualified Cardano.Chain.UTxO.UTxO as L +import qualified Cardano.Chain.UTxO.Validation as L +import qualified Cardano.Ledger.Allegra.Rules as L import qualified Cardano.Ledger.Alonzo.PParams as Ledger +import qualified Cardano.Ledger.Alonzo.Rules as L +import qualified Cardano.Ledger.Alonzo.Tx as L +import qualified Cardano.Ledger.Api as L import qualified Cardano.Ledger.Babbage.PParams as Ledger +import qualified Cardano.Ledger.Babbage.Rules as L import Cardano.Ledger.BaseTypes (strictMaybeToMaybe) +import qualified Cardano.Ledger.BaseTypes as L import qualified Cardano.Ledger.BaseTypes as Ledger +import Cardano.Ledger.Binary +import qualified Cardano.Ledger.Binary.Plain as Plain +import qualified Cardano.Ledger.Coin as L import qualified Cardano.Ledger.Conway.PParams as Ledger +import qualified Cardano.Ledger.Conway.Rules as L +import qualified Cardano.Ledger.Conway.TxCert as L +import qualified Cardano.Ledger.Core as L import Cardano.Ledger.Crypto (StandardCrypto) import qualified Cardano.Ledger.Crypto as CC (Crypto) import qualified Cardano.Ledger.Crypto as Crypto +import qualified Cardano.Ledger.Crypto as L import Cardano.Ledger.HKD (NoUpdate (..)) +import qualified Cardano.Ledger.Keys as L.Keys +import qualified Cardano.Ledger.SafeHash as L +import qualified Cardano.Ledger.Shelley.API.Mempool as L import qualified Cardano.Ledger.Shelley.PParams as Ledger +import qualified Cardano.Ledger.Shelley.Rules as L +import qualified Cardano.Ledger.Shelley.TxBody as L +import qualified Cardano.Ledger.Shelley.TxCert as L import qualified Cardano.Protocol.TPraos.API as Ledger import Cardano.Protocol.TPraos.BHeader (HashHeader (..)) +import qualified Cardano.Protocol.TPraos.Rules.Prtcl as L import qualified Cardano.Protocol.TPraos.Rules.Prtcl as Ledger import qualified Cardano.Protocol.TPraos.Rules.Tickn as Ledger import Ouroboros.Consensus.Byron.Ledger.Block (ByronHash (..)) @@ -36,20 +69,129 @@ import Ouroboros.Consensus.Protocol.Praos (PraosState) import qualified Ouroboros.Consensus.Protocol.Praos as Consensus import Ouroboros.Consensus.Protocol.TPraos (TPraosState) import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus +import qualified Ouroboros.Consensus.Shelley.Eras as Consensus import Ouroboros.Consensus.Shelley.Ledger.Block (ShelleyHash (..)) import qualified Ouroboros.Consensus.Shelley.Ledger.Query as Consensus import Ouroboros.Network.Block (HeaderHash, Tip (..)) import qualified Codec.Binary.Bech32 as Bech32 import qualified Codec.CBOR.Read as CBOR -import Data.Aeson (KeyValue ((.=)), ToJSON (..), object, pairs, (.=)) +import Data.Aeson (KeyValue ((.=)), ToJSON (..), ToJSONKey (..), object, pairs) import qualified Data.Aeson as Aeson import qualified Data.ByteString.Base16 as Base16 import qualified Data.ByteString.Short as SBS import Data.Data (Data) +import Data.Kind (Constraint, Type) import Data.Maybe.Strict (StrictMaybe (..)) import Data.Monoid import qualified Data.Text.Encoding as Text +import Data.Typeable (Typeable) +import GHC.Generics +import GHC.Stack (HasCallStack) +import GHC.TypeLits +import Lens.Micro + +deriving instance Generic (L.ApplyTxError era) +deriving instance Generic (L.Registration.TooLarge a) +deriving instance Generic L.ApplicationNameError +deriving instance Generic L.ApplyMempoolPayloadErr +deriving instance Generic L.Endorsement.Error +deriving instance Generic L.Interface.Error +deriving instance Generic L.LovelaceError +deriving instance Generic L.Registration.Adopted +deriving instance Generic L.Registration.Error +deriving instance Generic L.Scheduling.Error +deriving instance Generic L.SoftwareVersionError +deriving instance Generic L.SystemTagError +deriving instance Generic L.TxValidationError +deriving instance Generic L.UTxOError +deriving instance Generic L.UTxOValidationError +deriving instance Generic L.Voting.Error + +deriving anyclass instance ToJSON L.ApplicationNameError +deriving anyclass instance ToJSON L.ApplyMempoolPayloadErr +deriving anyclass instance ToJSON L.Endorsement.Error +deriving anyclass instance ToJSON L.Interface.Error +deriving anyclass instance ToJSON L.LovelaceError +deriving anyclass instance ToJSON L.Registration.Adopted +deriving anyclass instance ToJSON L.Registration.ApplicationVersion +deriving anyclass instance ToJSON L.Registration.Error +deriving anyclass instance ToJSON L.Scheduling.Error +deriving anyclass instance ToJSON L.SoftwareVersionError +deriving anyclass instance ToJSON L.SystemTagError +deriving anyclass instance ToJSON L.TxValidationError +deriving anyclass instance ToJSON L.UTxOError +deriving anyclass instance ToJSON L.UTxOValidationError +deriving anyclass instance ToJSON L.Voting.Error +deriving anyclass instance ToJSON L.VotingPeriod + +deriving anyclass instance ToJSON (L.GenesisDelegCert L.StandardCrypto) +deriving anyclass instance ToJSON (L.MIRCert L.StandardCrypto) +deriving anyclass instance ToJSON (L.MIRTarget L.StandardCrypto) +deriving anyclass instance ToJSON (L.PoolCert L.StandardCrypto) +deriving anyclass instance ToJSON (L.ShelleyDelegCert L.StandardCrypto) + +deriving anyclass instance + ( ToJSON (L.PredicateFailure (L.EraRule "UTXOW" ledgerera)) + , ToJSON (L.PredicateFailure (L.EraRule "DELEGS" ledgerera)) + ) => ToJSON (L.ShelleyLedgerPredFailure ledgerera) + +deriving anyclass instance + ( L.Crypto (L.EraCrypto ledgerera) + , ToJSON (L.PredicateFailure (L.EraRule "UTXO" ledgerera)) + ) => ToJSON (L.ShelleyUtxowPredFailure ledgerera) + +deriving anyclass instance + ( L.Crypto (L.EraCrypto ledgerera) + , ToJSON (L.PredicateFailure (L.EraRule "UTXO" ledgerera)) + ) => ToJSON (L.ShelleyPpupPredFailure ledgerera) + +deriving anyclass instance + ( L.Crypto (L.EraCrypto ledgerera) + , ToJSON (L.PredicateFailure (L.EraRule "UTXO" ledgerera)) + , ToJSON (L.ScriptPurpose ledgerera) + ) => ToJSON (L.AlonzoUtxowPredFailure ledgerera) + +deriving anyclass instance + ( L.Crypto (L.EraCrypto ledgerera) + , ToJSON (L.PredicateFailure (L.EraRule "UTXO" ledgerera)) + , ToJSON (L.TxCert ledgerera) + ) => ToJSON (L.BabbageUtxowPredFailure ledgerera) + +deriving anyclass instance + ( L.Crypto (L.EraCrypto ledgerera) + , ToJSON (L.GenesisDelegCert (Consensus.EraCrypto ledgerera)) + , ToJSON (L.MIRCert (Consensus.EraCrypto ledgerera)) + , ToJSON (L.PoolCert (Consensus.EraCrypto ledgerera)) + , ToJSON (L.ShelleyDelegCert (Consensus.EraCrypto ledgerera)) + ) => ToJSON (L.ShelleyTxCert ledgerera) + +deriving anyclass instance + ( L.Crypto (L.EraCrypto ledgerera) + , ToJSON (L.TxCert ledgerera) + ) => ToJSON (L.ScriptPurpose ledgerera) + +deriving anyclass instance + ( ToJSON (L.PredicateFailure (L.EraRule "LEDGER" ledgerera)) + ) => ToJSON (L.ApplyTxError ledgerera) + +deriving via ShowOf (L.ConwayTxCert c) instance Show (L.ConwayTxCert c) => ToJSON (L.ConwayTxCert c) +deriving via ShowOf (L.Keys.VKey L.Keys.Witness c) instance L.Crypto c => ToJSON (L.Keys.VKey L.Keys.Witness c) + +deriving via ShowOf (L.AllegraUtxoPredFailure ledgerera) instance Show (L.AllegraUtxoPredFailure ledgerera) => ToJSON (L.AllegraUtxoPredFailure ledgerera) +deriving via ShowOf (L.AlonzoUtxoPredFailure ledgerera) instance Show (L.AlonzoUtxoPredFailure ledgerera) => ToJSON (L.AlonzoUtxoPredFailure ledgerera) +deriving via ShowOf (L.BabbageUtxoPredFailure ledgerera) instance Show (L.BabbageUtxoPredFailure ledgerera) => ToJSON (L.BabbageUtxoPredFailure ledgerera) +deriving via ShowOf (L.ConwayLedgerPredFailure ledgerera) instance Show (L.ConwayLedgerPredFailure ledgerera) => ToJSON (L.ConwayLedgerPredFailure ledgerera) +deriving via ShowOf (L.ShelleyDelegsPredFailure ledgerera) instance Show (L.ShelleyDelegsPredFailure ledgerera) => ToJSON (L.ShelleyDelegsPredFailure ledgerera) +deriving via ShowOf (L.ShelleyUtxoPredFailure ledgerera) instance Show (L.ShelleyUtxoPredFailure ledgerera) => ToJSON (L.ShelleyUtxoPredFailure ledgerera) + +deriving instance ToJSON a => ToJSON (L.Registration.TooLarge a) + +deriving via ShowOf L.MIRPot instance ToJSON L.MIRPot +deriving via ShowOf L.KeyHash instance ToJSON L.KeyHash +deriving via ShowOf L.RdmrPtr instance ToJSON L.RdmrPtr + +deriving via ShowOf L.ApplicationName instance ToJSONKey L.ApplicationName deriving instance Data DecoderError deriving instance Data CBOR.DeserialiseFailure diff --git a/cardano-api/internal/Cardano/Api/Pretty.hs b/cardano-api/internal/Cardano/Api/Pretty.hs index 86d825452f..46e82ea503 100644 --- a/cardano-api/internal/Cardano/Api/Pretty.hs +++ b/cardano-api/internal/Cardano/Api/Pretty.hs @@ -19,6 +19,8 @@ module Cardano.Api.Pretty , white ) where +import Cardano.Api.Via.ShowOf + import qualified Data.Text as Text import qualified Data.Text.Lazy as TextLazy import Prettyprinter @@ -28,14 +30,6 @@ import Prettyprinter.Render.Terminal -- of colored output. This is a type alias for AnsiStyle. type Ann = AnsiStyle -newtype ShowOf a = ShowOf a - -instance Show a => Show (ShowOf a) where - show (ShowOf a) = show a - -instance Show a => Pretty (ShowOf a) where - pretty = viaShow - prettyToString :: Doc AnsiStyle -> String prettyToString = show diff --git a/cardano-api/internal/Cardano/Api/Via/ShowOf.hs b/cardano-api/internal/Cardano/Api/Via/ShowOf.hs new file mode 100644 index 0000000000..bca7b3e2fe --- /dev/null +++ b/cardano-api/internal/Cardano/Api/Via/ShowOf.hs @@ -0,0 +1,23 @@ +module Cardano.Api.Via.ShowOf + ( ShowOf(..) + ) where + +import Data.Aeson +import qualified Data.Aeson.Key as Key +import Data.Aeson.Types +import qualified Data.Text as Text +import Prettyprinter + +newtype ShowOf a = ShowOf a + +instance Show a => Show (ShowOf a) where + show (ShowOf a) = show a + +instance Show a => Pretty (ShowOf a) where + pretty = viaShow + +instance Show a => ToJSON (ShowOf a) where + toJSON (ShowOf a) = String (Text.pack (show a)) + +instance Show a => ToJSONKey (ShowOf a) where + toJSONKey = toJSONKeyKey (Key.fromString . show)