module Cardano.Api.Network.IPC.Internal.Version
  ( isQuerySupportedInNtcVersion
  , NodeToClientVersion (..)

    -- *** Error types
  , UnsupportedNtcVersionError (..)
  )
where

import Cardano.Api.Error
import Cardano.Api.Pretty

import Cardano.Protocol.Crypto
import Ouroboros.Consensus.Cardano.Block qualified as Consensus
import Ouroboros.Consensus.Cardano.Node ()
import Ouroboros.Consensus.Ledger.Query qualified as Consensus
import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
import Ouroboros.Network.NodeToClient.Version (NodeToClientVersion (..))
import Ouroboros.Network.Protocol.LocalStateQuery.Codec

-- | LocalStateQuery uses versioned queries, which means it requires the Node to support a minimum
-- (and possibly maximum) Node-to-Client version.
--
-- Background: The node to client LocalStateQuery protocol is such that it will disconnect on any
-- unrecognised queries.  This means that for a Node-to-Client connection, if a query is sent
-- that was introduced in a Node-to-Client version that is newer than the Node-To-Client version
-- of the connection, the node will disconnect the client.  The client will not get any
-- information about why the disconnect happened.  This is a bad user experience for tools
-- such as the CLI.
--
-- To improve the user experience the API needs to prevent the sending of queries that are
-- newer than the Node-To-Client version of the connection by checking the version of the
-- query before sending it.  This affords the ability to return @'UnsupportedNtcVersionError'('UnsupportedNtcVersionError')@,
-- informing the caller of a Node-To-Client versioning issue.
--
-- For maintaining typeclass instances, see the 'NodeToClientVersion' type documentation for
-- a list of versions and the queries that were introduced for those versions.
--
-- More information about queries versioning can be found:
--   * https://ouroboros-network.cardano.intersectmbo.org/ouroboros-network/Ouroboros-Network-NodeToClient.html#t:NodeToClientVersion
--   * https://ouroboros-consensus.cardano.intersectmbo.org/docs/for-developers/QueryVersioning/#implementation
isQuerySupportedInNtcVersion
  :: Some (Consensus.Query (Consensus.CardanoBlock StandardCrypto))
  -> NodeToClientVersion
  -> Either UnsupportedNtcVersionError ()
isQuerySupportedInNtcVersion :: Some (Query (CardanoBlock StandardCrypto))
-> NodeToClientVersion -> Either UnsupportedNtcVersionError ()
isQuerySupportedInNtcVersion (Some Query (CardanoBlock StandardCrypto) a
q) NodeToClientVersion
ntc =
  if Query (CardanoBlock StandardCrypto) a
-> NodeToClientVersion -> Bool
forall blk result.
(SupportedNetworkProtocolVersion blk,
 BlockSupportsLedgerQuery blk) =>
Query blk result -> NodeToClientVersion -> Bool
Consensus.queryIsSupportedOnNodeToClientVersion Query (CardanoBlock StandardCrypto) a
q NodeToClientVersion
ntc
    then () -> Either UnsupportedNtcVersionError ()
forall a b. b -> Either a b
Right ()
    else UnsupportedNtcVersionError -> Either UnsupportedNtcVersionError ()
forall a b. a -> Either a b
Left (UnsupportedNtcVersionError
 -> Either UnsupportedNtcVersionError ())
-> UnsupportedNtcVersionError
-> Either UnsupportedNtcVersionError ()
forall a b. (a -> b) -> a -> b
$ NodeToClientVersion
-> [NodeToClientVersion] -> UnsupportedNtcVersionError
UnsupportedNtcVersionError NodeToClientVersion
ntc (Query (CardanoBlock StandardCrypto) a -> [NodeToClientVersion]
forall blk result.
(SupportedNetworkProtocolVersion blk,
 BlockSupportsLedgerQuery blk) =>
Query blk result -> [NodeToClientVersion]
Consensus.querySupportedVersions Query (CardanoBlock StandardCrypto) a
q)

data UnsupportedNtcVersionError
  = UnsupportedNtcVersionError
      !NodeToClientVersion
      -- ^ The version we negotiated
      ![NodeToClientVersion]
      -- ^ The versions in which this query is supported
  deriving (UnsupportedNtcVersionError -> UnsupportedNtcVersionError -> Bool
(UnsupportedNtcVersionError -> UnsupportedNtcVersionError -> Bool)
-> (UnsupportedNtcVersionError
    -> UnsupportedNtcVersionError -> Bool)
-> Eq UnsupportedNtcVersionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnsupportedNtcVersionError -> UnsupportedNtcVersionError -> Bool
== :: UnsupportedNtcVersionError -> UnsupportedNtcVersionError -> Bool
$c/= :: UnsupportedNtcVersionError -> UnsupportedNtcVersionError -> Bool
/= :: UnsupportedNtcVersionError -> UnsupportedNtcVersionError -> Bool
Eq, Int -> UnsupportedNtcVersionError -> ShowS
[UnsupportedNtcVersionError] -> ShowS
UnsupportedNtcVersionError -> String
(Int -> UnsupportedNtcVersionError -> ShowS)
-> (UnsupportedNtcVersionError -> String)
-> ([UnsupportedNtcVersionError] -> ShowS)
-> Show UnsupportedNtcVersionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnsupportedNtcVersionError -> ShowS
showsPrec :: Int -> UnsupportedNtcVersionError -> ShowS
$cshow :: UnsupportedNtcVersionError -> String
show :: UnsupportedNtcVersionError -> String
$cshowList :: [UnsupportedNtcVersionError] -> ShowS
showList :: [UnsupportedNtcVersionError] -> ShowS
Show)

instance Error UnsupportedNtcVersionError where
  prettyError :: forall ann. UnsupportedNtcVersionError -> Doc ann
prettyError (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)."