{-# LANGUAGE TypeApplications #-}

module Cardano.CLI.LocalStateQuery
  ( checkNodeNetworkId
  )
where

import Cardano.Api
import Cardano.Api.Network qualified as Consensus

import Cardano.CLI.Compatible.Exception (throwCliError)
import Cardano.CLI.Type.Error.NodeNetworkIdMismatchError

import Control.Exception (IOException, try)
import Control.Monad ((>=>))
import Control.Monad.Trans.Maybe (MaybeT (..))
import Data.Either.Extra (eitherToMaybe)

-- | Check that the network id the CLI was given matches the network id in the
-- node's genesis, and throw a 'NodeNetworkIdMismatchError' otherwise. This is
-- meant to be run once, before a command that talks to the node.
--
-- The node-to-client handshake only compares network magics, so a 'NetworkId'
-- with the right magic but the wrong tag (for example
-- @CARDANO_NODE_NETWORK_ID=764824073@ instead of @CARDANO_NODE_NETWORK_ID=mainnet@)
-- connects successfully and would otherwise make the CLI render addresses for
-- the wrong network.
--
-- When there is no evidence of a mismatch (the node cannot be reached, it is
-- still in the Byron era, or it does not support the necessary queries) the
-- check passes, and connection problems are left to be reported by the command
-- itself.
checkNodeNetworkId :: MonadIO m => LocalNodeConnectInfo -> m ()
checkNodeNetworkId :: forall (m :: * -> *). MonadIO m => LocalNodeConnectInfo -> m ()
checkNodeNetworkId LocalNodeConnectInfo
connectInfo = do
  result <-
    IO (Either IOException (Either AcquiringFailure (Maybe NetworkId)))
-> m (Either
        IOException (Either AcquiringFailure (Maybe NetworkId)))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Either IOException (Either AcquiringFailure (Maybe NetworkId)))
 -> m (Either
         IOException (Either AcquiringFailure (Maybe NetworkId))))
-> (IO (Either AcquiringFailure (Maybe NetworkId))
    -> IO
         (Either IOException (Either AcquiringFailure (Maybe NetworkId))))
-> IO (Either AcquiringFailure (Maybe NetworkId))
-> m (Either
        IOException (Either AcquiringFailure (Maybe NetworkId)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO (Either AcquiringFailure (Maybe NetworkId))
 -> m (Either
         IOException (Either AcquiringFailure (Maybe NetworkId))))
-> IO (Either AcquiringFailure (Maybe NetworkId))
-> m (Either
        IOException (Either AcquiringFailure (Maybe NetworkId)))
forall a b. (a -> b) -> a -> b
$
      LocalNodeConnectInfo
-> Target ChainPoint
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (Maybe NetworkId)
-> IO (Either AcquiringFailure (Maybe NetworkId))
forall a.
LocalNodeConnectInfo
-> Target ChainPoint
-> LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO a
-> IO (Either AcquiringFailure a)
executeLocalStateQueryExpr LocalNodeConnectInfo
connectInfo Target ChainPoint
forall point. Target point
Consensus.VolatileTip LocalStateQueryExpr
  BlockInMode ChainPoint QueryInMode () IO (Maybe NetworkId)
queryNodeNetworkId
  case result of
    Right (Right (Just NetworkId
nodeNetId))
      | NetworkId
nodeNetId NetworkId -> NetworkId -> Bool
forall a. Eq a => a -> a -> Bool
/= NetworkId
cliNetId ->
          NodeNetworkIdMismatchError -> m ()
forall e (m :: * -> *) a.
(HasCallStack, Show e, Typeable e, Error e, MonadIO m) =>
e -> m a
throwCliError (NodeNetworkIdMismatchError -> m ())
-> NodeNetworkIdMismatchError -> m ()
forall a b. (a -> b) -> a -> b
$ NetworkId -> NetworkId -> NodeNetworkIdMismatchError
NodeNetworkIdMismatchError NetworkId
cliNetId NetworkId
nodeNetId
    Either IOException (Either AcquiringFailure (Maybe NetworkId))
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  cliNetId :: NetworkId
cliNetId = LocalNodeConnectInfo -> NetworkId
localNodeNetworkId LocalNodeConnectInfo
connectInfo

-- | The network id from the node's genesis, or 'Nothing' when it cannot be
-- obtained (the node is still in the Byron era, or it does not support the
-- necessary queries): the absence of an answer is not treated as a mismatch.
queryNodeNetworkId
  :: LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO (Maybe NetworkId)
queryNodeNetworkId :: LocalStateQueryExpr
  BlockInMode ChainPoint QueryInMode () IO (Maybe NetworkId)
queryNodeNetworkId = MaybeT
  (LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO)
  NetworkId
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (Maybe NetworkId)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT
   (LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO)
   NetworkId
 -> LocalStateQueryExpr
      BlockInMode ChainPoint QueryInMode () IO (Maybe NetworkId))
-> MaybeT
     (LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO)
     NetworkId
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (Maybe NetworkId)
forall a b. (a -> b) -> a -> b
$ do
  AnyCardanoEra era <- LocalStateQueryExpr
  BlockInMode ChainPoint QueryInMode () IO (Maybe AnyCardanoEra)
-> MaybeT
     (LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO)
     AnyCardanoEra
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (LocalStateQueryExpr
   BlockInMode ChainPoint QueryInMode () IO (Maybe AnyCardanoEra)
 -> MaybeT
      (LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO)
      AnyCardanoEra)
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (Maybe AnyCardanoEra)
-> MaybeT
     (LocalStateQueryExpr BlockInMode ChainPoint QueryInMode () IO)
     AnyCardanoEra
forall a b. (a -> b) -> a -> b
$ Either UnsupportedNtcVersionError AnyCardanoEra
-> Maybe AnyCardanoEra
forall a b. Either a b -> Maybe b
eitherToMaybe (Either UnsupportedNtcVersionError AnyCardanoEra
 -> Maybe AnyCardanoEra)
-> LocalStateQueryExpr
     BlockInMode
     ChainPoint
     QueryInMode
     ()
     IO
     (Either UnsupportedNtcVersionError AnyCardanoEra)
-> LocalStateQueryExpr
     BlockInMode ChainPoint QueryInMode () IO (Maybe AnyCardanoEra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocalStateQueryExpr
  BlockInMode
  ChainPoint
  QueryInMode
  ()
  IO
  (Either UnsupportedNtcVersionError AnyCardanoEra)
forall block point r.
LocalStateQueryExpr
  block
  point
  QueryInMode
  r
  IO
  (Either UnsupportedNtcVersionError AnyCardanoEra)
queryCurrentEra
  sbe <- MaybeT . pure $ forEraMaybeEon era
  genesisParameters <- MaybeT $ (eitherToMaybe >=> eitherToMaybe) <$> queryGenesisParameters sbe
  pure $ protocolParamNetworkId genesisParameters