ToJSON instances for error types

cardano-submit-api/cardano-submit-api.cabal

@@ -68,8 +68,8 @@ library
   other-modules:        Cardano.TxSubmit.CLI.Parsers
                       , Cardano.TxSubmit.CLI.Types
                       , Cardano.TxSubmit.Config
-                      , Cardano.TxSubmit.ErrorRender
                       , Cardano.TxSubmit.Metrics
+                      , Cardano.TxSubmit.Orphans
                       , Cardano.TxSubmit.Rest.Parsers
                       , Cardano.TxSubmit.Rest.Types
                       , Cardano.TxSubmit.Rest.Web

cardano-submit-api/src/Cardano/TxSubmit/Orphans.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Cardano.TxSubmit.Orphans
+  (
+  ) where
+
+import           Cardano.Api
+import           Cardano.Binary (DecoderError)
+import           Data.Aeson (ToJSON (..))
+import qualified Data.Aeson as Aeson
+import           Ouroboros.Consensus.Cardano.Block
+
+instance ToJSON DecoderError where
+  toJSON = Aeson.String . textShow
+
+deriving anyclass instance ToJSON EraMismatch

cardano-submit-api/src/Cardano/TxSubmit/Types.hs

@@ -1,7 +1,11 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeOperators #-}
 
 module Cardano.TxSubmit.Types
@@ -16,32 +20,37 @@ module Cardano.TxSubmit.Types
   , renderTxCmdError
   ) where
 
-import           Cardano.Api (AnyCardanoEra, Error (..), TxId, textShow)
+import           Cardano.Api (AnyCardanoEra, Error (..), TxId, TxValidationErrorInCardanoMode (..),
+                   textShow)
 import           Cardano.Api.Pretty
 import           Cardano.Binary (DecoderError)
-import           Data.Aeson (ToJSON (..), Value (..))
+import           Cardano.TxSubmit.Orphans ()
+import           Data.Aeson (ToJSON (..), Value (..), (.=))
+import qualified Data.Aeson as Aeson
 import           Data.ByteString.Char8 (ByteString)
 import           Data.Text (Text)
 import           Formatting (build, sformat)
 import           GHC.Generics (Generic)
 import           Network.HTTP.Media ((//))
-import           Ouroboros.Consensus.Cardano.Block (EraMismatch (..))
 import           Servant (Accept (..), JSON, MimeRender (..), MimeUnrender (..), PostAccepted,
                    ReqBody, (:>))
 import           Servant.API.Generic (ToServantApi, (:-))
 
 import qualified Data.ByteString.Lazy.Char8 as LBS
+import qualified Data.Text as T
 
 newtype TxSubmitPort = TxSubmitPort Int
 
 -- | The errors that the raw CBOR transaction parsing\/decoding functions can return.
 --
 newtype RawCborDecodeError = RawCborDecodeError [DecoderError]
-  deriving (Eq, Show)
+  deriving (Eq, Generic, Show)
 
 instance Error RawCborDecodeError where
   prettyError (RawCborDecodeError decodeErrors) = "RawCborDecodeError decode error: " <> pshow (fmap pshow decodeErrors)
 
+deriving anyclass instance ToJSON RawCborDecodeError
+
 -- | An error that can occur in the transaction submission web API.
 data TxSubmitWebApiError
   = TxSubmitDecodeHex
@@ -50,36 +59,51 @@ data TxSubmitWebApiError
   | TxSubmitBadTx !Text
   | TxSubmitFail TxCmdError
 
-newtype EnvSocketError = CliEnvVarLookup Text deriving (Eq, Show)
+deriving instance Generic TxSubmitWebApiError
+
+deriving anyclass instance ToJSON TxSubmitWebApiError
+
+newtype EnvSocketError = CliEnvVarLookup Text
+  deriving (Eq, Generic, Show)
+
+instance ToJSON EnvSocketError where
+  toJSON (CliEnvVarLookup msg) = Aeson.object
+    [ "message" .= String msg
+    ]
 
 data TxCmdError
   = TxCmdSocketEnvError EnvSocketError
   | TxCmdEraConsensusModeMismatch !AnyCardanoEra
   | TxCmdTxReadError !RawCborDecodeError
-  | TxCmdTxSubmitError !Text
-  | TxCmdTxSubmitErrorEraMismatch !EraMismatch
+  | TxCmdTxSubmitValidationError !TxValidationErrorInCardanoMode
+
+deriving instance Generic TxCmdError
 
-instance ToJSON TxSubmitWebApiError where
-  toJSON = convertJson
+deriving anyclass instance ToJSON TxCmdError
 
-convertJson :: TxSubmitWebApiError -> Value
-convertJson = String . renderTxSubmitWebApiError
+-- data TxValidationErrorInEra where
+--   TxValidationErrorInEra :: CardanoEra era -> TxValidationError era -> TxValidationErrorInEra
 
 renderTxCmdError :: TxCmdError -> Text
-renderTxCmdError (TxCmdSocketEnvError socketError) = "socket env error " <> textShow socketError
-renderTxCmdError (TxCmdEraConsensusModeMismatch era) = "era consensus mode mismatch " <> textShow era
-renderTxCmdError (TxCmdTxReadError envelopeError) = "transaction read error " <> textShow envelopeError
-renderTxCmdError (TxCmdTxSubmitError msg) = "transaction submit error " <> msg
-renderTxCmdError (TxCmdTxSubmitErrorEraMismatch eraMismatch) = "transaction submit era mismatch" <> textShow eraMismatch
+renderTxCmdError = \case
+  TxCmdSocketEnvError socketError ->
+    "socket env error " <> textShow socketError
+  TxCmdEraConsensusModeMismatch era ->
+    "era consensus mode mismatch " <> textShow era
+  TxCmdTxReadError envelopeError ->
+    "transaction read error " <> textShow envelopeError
+  TxCmdTxSubmitValidationError e ->
+    case e of
+      TxValidationErrorInCardanoMode err -> "transaction submit error " <> T.pack (show err)
+      TxValidationEraMismatch eraMismatch -> "transaction submit era mismatch" <> textShow eraMismatch
 
 renderTxSubmitWebApiError :: TxSubmitWebApiError -> Text
-renderTxSubmitWebApiError st =
-  case st of
-    TxSubmitDecodeHex -> "Provided data was hex encoded and this webapi expects raw binary"
-    TxSubmitEmpty -> "Provided transaction has zero length"
-    TxSubmitDecodeFail err -> sformat build err
-    TxSubmitBadTx tt -> mconcat ["Transactions of type '", tt, "' not supported"]
-    TxSubmitFail err -> renderTxCmdError err
+renderTxSubmitWebApiError = \case
+  TxSubmitDecodeHex -> "Provided data was hex encoded and this webapi expects raw binary"
+  TxSubmitEmpty -> "Provided transaction has zero length"
+  TxSubmitDecodeFail err -> sformat build err
+  TxSubmitBadTx tt -> mconcat ["Transactions of type '", tt, "' not supported"]
+  TxSubmitFail err -> renderTxCmdError err
 
 -- | Servant API which provides access to tx submission webapi
 type TxSubmitApi = "api" :> ToServantApi TxSubmitApiRecord

cardano-submit-api/src/Cardano/TxSubmit/Web.hs

@@ -27,13 +27,13 @@ import           Cardano.TxSubmit.Metrics (TxSubmitMetrics (..))
 import           Cardano.TxSubmit.Rest.Types (WebserverConfig (..), toWarpSettings)
 import qualified Cardano.TxSubmit.Rest.Web as Web
 import           Cardano.TxSubmit.Types (EnvSocketError (..), RawCborDecodeError (..),
-                   TxCmdError (TxCmdTxReadError, TxCmdTxSubmitError, TxCmdTxSubmitErrorEraMismatch),
-                   TxSubmitApi, TxSubmitApiRecord (..), TxSubmitWebApiError (TxSubmitFail),
-                   renderTxCmdError)
+                   TxCmdError (..), TxSubmitApi, TxSubmitApiRecord (..),
+                   TxSubmitWebApiError (TxSubmitFail), renderTxCmdError)
 import           Cardano.TxSubmit.Util (logException)
 import           Ouroboros.Consensus.Cardano.Block (EraMismatch (..))
 import qualified Ouroboros.Network.Protocol.LocalTxSubmission.Client as Net.Tx
 
+import           Cardano.TxSubmit.Types (TxCmdError (..))
 import           Control.Applicative (Applicative (pure), (<$>))
 import           Control.Monad (Functor (fmap), Monad (return), (=<<))
 import           Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT)
@@ -59,17 +59,16 @@ import           Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import qualified Data.Text.IO as T
+import qualified Servant
+import           Servant (Application, Handler, ServerError (..), err400, throwError)
+import           Servant.API.Generic (toServant)
+import           Servant.Server.Generic (AsServerT)
 import           System.Environment (lookupEnv)
 import qualified System.IO as IO
 import           System.IO (IO)
 import qualified System.Metrics.Prometheus.Metric.Gauge as Gauge
 import           Text.Show (Show (show))
 
-import qualified Servant
-import           Servant (Application, Handler, ServerError (..), err400, throwError)
-import           Servant.API.Generic (toServant)
-import           Servant.Server.Generic (AsServerT)
-
 runTxSubmitServer
   :: Trace IO Text
   -> TxSubmitMetrics
@@ -147,10 +146,8 @@ txSubmitPost trace metrics p@(CardanoModeParams cModeParams) networkId socketPat
       Net.Tx.SubmitSuccess -> do
         liftIO $ T.putStrLn "Transaction successfully submitted."
         return $ getTxId (getTxBody tx)
-      Net.Tx.SubmitFail reason ->
-        case reason of
-          TxValidationErrorInCardanoMode err -> left . TxCmdTxSubmitError . T.pack $ show err
-          TxValidationEraMismatch mismatchErr -> left $ TxCmdTxSubmitErrorEraMismatch mismatchErr
+      Net.Tx.SubmitFail e ->
+        left $ TxCmdTxSubmitValidationError e
     where
       handle :: ExceptT TxCmdError IO TxId -> Handler TxId
       handle f = do

cardano-testnet/test/cardano-testnet-test/files/golden/tx.failed.response.golden

@@ -1 +1 @@
-"transaction submit error ShelleyTxValidationError ShelleyBasedEraBabbage (ApplyTxError [UtxowFailure (UtxoFailure (AlonzoInBabbageUtxoPredFailure (ValueNotConservedUTxO (MaryValue (Coin 0) (MultiAsset (fromList []))) (MaryValue (Coin 300000000000) (MultiAsset (fromList [])))))),UtxowFailure (UtxoFailure (AlonzoInBabbageUtxoPredFailure (BadInputsUTxO (fromList [TxIn (TxId {unTxId = SafeHash \"xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\"}) (TxIx 0)]))))])"
+{"contents":{"contents":{"contents":{"era":"ShelleyBasedEraBabbage","error":[{"contents":{"contents":"AlonzoInBabbageUtxoPredFailure (ValueNotConservedUTxO (MaryValue (Coin 0) (MultiAsset (fromList []))) (MaryValue (Coin 300000000000) (MultiAsset (fromList []))))","tag":"UtxoFailure"},"tag":"UtxowFailure"},{"contents":{"contents":"AlonzoInBabbageUtxoPredFailure (BadInputsUTxO (fromList [TxIn (TxId {unTxId = SafeHash \"xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\"}) (TxIx 0)]))","tag":"UtxoFailure"},"tag":"UtxowFailure"}],"kind":"ShelleyTxValidationError"},"tag":"TxValidationErrorInCardanoMode"},"tag":"TxCmdTxSubmitValidationError"},"tag":"TxSubmitFail"}