{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.CLI.Type.Error.QueryCmdError
  ( QueryCmdError (..)
  , renderQueryCmdError
  )
where

import Cardano.Api hiding (QueryInShelleyBasedEra (..))
import Cardano.Api.Consensus as Consensus (PastHorizonException)

import Cardano.CLI.Render
import Cardano.Prelude (SomeException)

import Data.ByteString.Lazy.Char8 qualified as LBS
import Data.Text.Lazy.Builder (toLazyText)
import Formatting.Buildable (build)

data QueryCmdError
  = QueryCmdWriteFileError !(FileError ())
  | QueryCmdAcquireFailure !AcquiringFailure
  | QueryCmdEraMismatch !EraMismatch
  | QueryCmdNodeToClientDisabled
  | QueryCmdPastHorizon !Consensus.PastHorizonException
  | QueryCmdSystemStartUnavailable
  | QueryCmdLeaderShipError !LeadershipError
  | QueryCmdProtocolStateDecodeFailure !(LBS.ByteString, DecoderError)
  | QueryCmdPoolStateDecodeError DecoderError
  | QueryCmdStakeSnapshotDecodeError DecoderError
  | QueryCmdUnsupportedNtcVersion !UnsupportedNtcVersionError
  | QueryCmdEraNotSupported !AnyCardanoEra
  | QueryBackwardCompatibleError
      !Text
      !SomeException
  deriving Int -> QueryCmdError -> ShowS
[QueryCmdError] -> ShowS
QueryCmdError -> String
(Int -> QueryCmdError -> ShowS)
-> (QueryCmdError -> String)
-> ([QueryCmdError] -> ShowS)
-> Show QueryCmdError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QueryCmdError -> ShowS
showsPrec :: Int -> QueryCmdError -> ShowS
$cshow :: QueryCmdError -> String
show :: QueryCmdError -> String
$cshowList :: [QueryCmdError] -> ShowS
showList :: [QueryCmdError] -> ShowS
Show

instance Error QueryCmdError where
  prettyError :: forall ann. QueryCmdError -> Doc ann
prettyError = QueryCmdError -> Doc ann
forall ann. QueryCmdError -> Doc ann
renderQueryCmdError

renderQueryCmdError :: QueryCmdError -> Doc ann
renderQueryCmdError :: forall ann. QueryCmdError -> Doc ann
renderQueryCmdError = \case
  -- TODO: This should eventually be removed as
  -- pre-mainnet eras should be handled by the compatible commands
  QueryCmdEraNotSupported AnyCardanoEra
anyEra ->
    Doc ann
"This query is not supported in the era: "
      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
anyEra
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
".\n"
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Please use a different query or switch to a compatible era."
  QueryCmdWriteFileError FileError ()
fileErr ->
    FileError () -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. FileError () -> Doc ann
prettyError FileError ()
fileErr
  QueryCmdAcquireFailure AcquiringFailure
acquireFail ->
    AcquiringFailure -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow AcquiringFailure
acquireFail
  QueryCmdError
QueryCmdNodeToClientDisabled -> Doc ann
"Node to client disabled"
  QueryCmdEraMismatch (EraMismatch Text
ledgerEra Text
queryEra) ->
    Doc ann
"\nAn error mismatch occurred."
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"\nSpecified query era: "
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
queryEra
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"\nCurrent ledger era: "
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
ledgerEra
  QueryCmdPastHorizon PastHorizonException
e ->
    Doc ann
"Past horizon: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> PastHorizonException -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow PastHorizonException
e
  QueryCmdError
QueryCmdSystemStartUnavailable ->
    Doc ann
"System start unavailable"
  QueryCmdLeaderShipError LeadershipError
e ->
    LeadershipError -> Doc ann
forall e ann. Error e => e -> Doc ann
forall ann. LeadershipError -> Doc ann
prettyError LeadershipError
e
  QueryCmdProtocolStateDecodeFailure (ByteString
_, DecoderError
decErr) ->
    Doc ann
"Failed to decode the protocol state: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
forall ann. Text -> Doc ann
pretty (Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ DecoderError -> Builder
forall p. Buildable p => p -> Builder
build DecoderError
decErr)
  QueryCmdPoolStateDecodeError DecoderError
decoderError ->
    Doc ann
"Failed to decode PoolState.  Error: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> DecoderError -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow DecoderError
decoderError
  QueryCmdStakeSnapshotDecodeError DecoderError
decoderError ->
    Doc ann
"Failed to decode StakeSnapshot.  Error: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> DecoderError -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow DecoderError
decoderError
  QueryCmdUnsupportedNtcVersion (UnsupportedNtcVersionError NodeToClientVersion
minNtcVersion [NodeToClientVersion]
ntcVersion) ->
    Doc ann
"Unsupported feature for the node-to-client protocol version.\n"
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"This query requires at least "
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> NodeToClientVersion -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow NodeToClientVersion
minNtcVersion
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
" but the node negotiated "
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> [NodeToClientVersion] -> Doc ann
forall a ann. Show a => a -> Doc ann
pshow [NodeToClientVersion]
ntcVersion
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
".\n"
      Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"Later node versions support later protocol versions (but development protocol versions are not enabled in the node by default)."
  QueryBackwardCompatibleError Text
cmdText SomeException
e ->
    Text -> (SomeException -> Doc ann) -> SomeException -> Doc ann
forall a ann. Text -> (a -> Doc ann) -> a -> Doc ann
renderAnyCmdError Text
cmdText SomeException -> Doc ann
forall a ann. Exception a => a -> Doc ann
prettyException SomeException
e