From bb1e0738d2f5dc9997f4f3909f6abfd27470114e Mon Sep 17 00:00:00 2001 From: John Ky Date: Tue, 21 Nov 2023 05:47:49 +1100 Subject: [PATCH] ToJSON instances for error types --- cardano-submit-api/cardano-submit-api.cabal | 2 +- .../src/Cardano/TxSubmit/ErrorRender.hs | 21 ------- .../src/Cardano/TxSubmit/Orphans.hs | 20 +++++++ .../src/Cardano/TxSubmit/Types.hs | 59 +++++++++++++------ 4 files changed, 61 insertions(+), 41 deletions(-) delete mode 100644 cardano-submit-api/src/Cardano/TxSubmit/ErrorRender.hs create mode 100644 cardano-submit-api/src/Cardano/TxSubmit/Orphans.hs diff --git a/cardano-submit-api/cardano-submit-api.cabal b/cardano-submit-api/cardano-submit-api.cabal index edb048bb133..2f31b39f39c 100644 --- a/cardano-submit-api/cardano-submit-api.cabal +++ b/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 diff --git a/cardano-submit-api/src/Cardano/TxSubmit/ErrorRender.hs b/cardano-submit-api/src/Cardano/TxSubmit/ErrorRender.hs deleted file mode 100644 index a6dc1537deb..00000000000 --- a/cardano-submit-api/src/Cardano/TxSubmit/ErrorRender.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Cardano.TxSubmit.ErrorRender - ( renderEraMismatch - ) where - --- This file contains error renders. They should have been defined at a lower level, with the error --- type definitions, but for some reason have not been. --- They will be defined here for now and then moved where they are supposed to be once they --- are working. - -import Data.Text (Text) -import Ouroboros.Consensus.Cardano.Block (EraMismatch (..)) - -renderEraMismatch :: EraMismatch -> Text -renderEraMismatch EraMismatch{ledgerEraName, otherEraName} = - "The era of the node and the tx do not match. " <> - "The node is running in the " <> ledgerEraName <> - " era, but the transaction is for the " <> otherEraName <> " era." - diff --git a/cardano-submit-api/src/Cardano/TxSubmit/Orphans.hs b/cardano-submit-api/src/Cardano/TxSubmit/Orphans.hs new file mode 100644 index 00000000000..afcfb0d52f7 --- /dev/null +++ b/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 diff --git a/cardano-submit-api/src/Cardano/TxSubmit/Types.hs b/cardano-submit-api/src/Cardano/TxSubmit/Types.hs index 4916c66aa0f..ff0a3efbf06 100644 --- a/cardano-submit-api/src/Cardano/TxSubmit/Types.hs +++ b/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 @@ -18,7 +22,9 @@ module Cardano.TxSubmit.Types import Cardano.Api (AnyCardanoEra, Error (..), TxId, textShow) 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) @@ -37,11 +43,13 @@ 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 displayError (RawCborDecodeError decodeErrors) = "RawCborDecodeError decode error: \n" <> L.intercalate " \n" (fmap show decodeErrors) +deriving anyclass instance ToJSON RawCborDecodeError + -- | An error that can occur in the transaction submission web API. data TxSubmitWebApiError = TxSubmitDecodeHex @@ -50,7 +58,17 @@ 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 @@ -59,27 +77,30 @@ data TxCmdError | TxCmdTxSubmitError !Text | TxCmdTxSubmitErrorEraMismatch !EraMismatch -instance ToJSON TxSubmitWebApiError where - toJSON = convertJson +deriving instance Generic TxCmdError -convertJson :: TxSubmitWebApiError -> Value -convertJson = String . renderTxSubmitWebApiError +deriving anyclass instance ToJSON TxCmdError 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 + TxCmdTxSubmitError msg -> + "transaction submit error " <> msg + TxCmdTxSubmitErrorEraMismatch 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