Merge pull request #379 from input-output-hk/newhoggy/json-instances-…

…for-TxValidationError

`ToJSON` instance for `TxValidationError`

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

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
   )
 

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.

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

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
 

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)