{-# 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.Binary (DecoderError)
import Cardano.CLI.Render
import Cardano.Prelude (SomeException)

import Data.ByteString.Lazy.Char8 qualified as LBS
import Data.Text (Text)
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 a ann. Pretty a => a -> Doc ann
forall ann. Text -> 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 a ann. Pretty a => a -> Doc ann
forall ann. Text -> 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