{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.CLI.EraIndependent.Debug.CheckNodeConfiguration.Run (runCheckNodeConfig) where

import Cardano.Api
import Cardano.Api.Byron qualified as Byron

import Cardano.CLI.EraIndependent.Debug.CheckNodeConfiguration.Command
import Cardano.CLI.Read qualified as Read
import Cardano.CLI.Type.Error.DebugCmdError
import Cardano.Crypto.Hash qualified as Crypto

import Control.Monad
import Data.Text qualified as Text
import Data.Yaml qualified as Yaml
import System.FilePath (takeDirectory, (</>))

runCheckNodeConfig :: CheckNodeConfigCmdArgs -> ExceptT DebugCmdError IO ()
runCheckNodeConfig :: CheckNodeConfigCmdArgs -> ExceptT DebugCmdError IO ()
runCheckNodeConfig (CheckNodeConfigCmdArgs NodeConfigFile 'In
configFile) = do
  NodeConfig
nodeConfig :: NodeConfig <- IO NodeConfig -> ExceptT DebugCmdError IO NodeConfig
forall a. IO a -> ExceptT DebugCmdError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO NodeConfig -> ExceptT DebugCmdError IO NodeConfig)
-> IO NodeConfig -> ExceptT DebugCmdError IO NodeConfig
forall a b. (a -> b) -> a -> b
$ String -> IO NodeConfig
forall (m :: * -> *) a. (MonadIO m, FromJSON a) => String -> m a
Yaml.decodeFileThrow String
configFilePath
  NodeConfigFile 'In -> NodeConfig -> ExceptT DebugCmdError IO ()
checkNodeGenesisConfiguration NodeConfigFile 'In
configFile NodeConfig
nodeConfig
  IO () -> ExceptT DebugCmdError IO ()
forall a. IO a -> ExceptT DebugCmdError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT DebugCmdError IO ())
-> IO () -> ExceptT DebugCmdError IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Successfully checked node configuration file: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
configFilePath
 where
  configFilePath :: String
configFilePath = NodeConfigFile 'In -> String
forall content (direction :: FileDirection).
File content direction -> String
unFile NodeConfigFile 'In
configFile

checkNodeGenesisConfiguration
  :: NodeConfigFile 'In
  -- ^ The node configuration file path. It's not read by this function, but used for producing error messages.
  -> NodeConfig
  -- ^ The parsed node configuration file
  -> ExceptT DebugCmdError IO ()
checkNodeGenesisConfiguration :: NodeConfigFile 'In -> NodeConfig -> ExceptT DebugCmdError IO ()
checkNodeGenesisConfiguration NodeConfigFile 'In
configFile NodeConfig
nodeConfig = do
  let byronGenFile :: String
byronGenFile = String -> String
adjustFilepath (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ File ByronGenesisConfig 'In -> String
forall content (direction :: FileDirection).
File content direction -> String
unFile (File ByronGenesisConfig 'In -> String)
-> File ByronGenesisConfig 'In -> String
forall a b. (a -> b) -> a -> b
$ NodeConfig -> File ByronGenesisConfig 'In
ncByronGenesisFile NodeConfig
nodeConfig
      alonzoGenFile :: String
alonzoGenFile = String -> String
adjustFilepath (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ File AlonzoGenesis 'In -> String
forall content (direction :: FileDirection).
File content direction -> String
unFile (File AlonzoGenesis 'In -> String)
-> File AlonzoGenesis 'In -> String
forall a b. (a -> b) -> a -> b
$ NodeConfig -> File AlonzoGenesis 'In
ncAlonzoGenesisFile NodeConfig
nodeConfig
      shelleyGenFile :: String
shelleyGenFile = String -> String
adjustFilepath (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ File ShelleyGenesisConfig 'In -> String
forall content (direction :: FileDirection).
File content direction -> String
unFile (File ShelleyGenesisConfig 'In -> String)
-> File ShelleyGenesisConfig 'In -> String
forall a b. (a -> b) -> a -> b
$ NodeConfig -> File ShelleyGenesisConfig 'In
ncShelleyGenesisFile NodeConfig
nodeConfig
  String
conwayGenFile <- case NodeConfig -> Maybe (File ConwayGenesisConfig 'In)
ncConwayGenesisFile NodeConfig
nodeConfig of
    Maybe (File ConwayGenesisConfig 'In)
Nothing -> DebugCmdError -> ExceptT DebugCmdError IO String
forall a. DebugCmdError -> ExceptT DebugCmdError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DebugCmdError -> ExceptT DebugCmdError IO String)
-> DebugCmdError -> ExceptT DebugCmdError IO String
forall a b. (a -> b) -> a -> b
$ String -> DebugCmdError
DebugNodeConfigNoConwayFileCmdError String
configFilePath
    Just File ConwayGenesisConfig 'In
conwayGenesisFile -> String -> ExceptT DebugCmdError IO String
forall a. a -> ExceptT DebugCmdError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> ExceptT DebugCmdError IO String)
-> String -> ExceptT DebugCmdError IO String
forall a b. (a -> b) -> a -> b
$ String -> String
adjustFilepath (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ File ConwayGenesisConfig 'In -> String
forall content (direction :: FileDirection).
File content direction -> String
unFile File ConwayGenesisConfig 'In
conwayGenesisFile

  IO () -> ExceptT DebugCmdError IO ()
forall a. IO a -> ExceptT DebugCmdError IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT DebugCmdError IO ())
-> IO () -> ExceptT DebugCmdError IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Checking byron genesis file: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
byronGenFile

  let expectedByronHash :: Text
expectedByronHash = GenesisHashByron -> Text
unGenesisHashByron (GenesisHashByron -> Text) -> GenesisHashByron -> Text
forall a b. (a -> b) -> a -> b
$ NodeConfig -> GenesisHashByron
ncByronGenesisHash NodeConfig
nodeConfig
      expectedAlonzoHash :: Text
expectedAlonzoHash = Hash Blake2b_256 ByteString -> Text
forall h a. Hash h a -> Text
Crypto.hashToTextAsHex (Hash Blake2b_256 ByteString -> Text)
-> Hash Blake2b_256 ByteString -> Text
forall a b. (a -> b) -> a -> b
$ GenesisHashAlonzo -> Hash Blake2b_256 ByteString
unGenesisHashAlonzo (GenesisHashAlonzo -> Hash Blake2b_256 ByteString)
-> GenesisHashAlonzo -> Hash Blake2b_256 ByteString
forall a b. (a -> b) -> a -> b
$ NodeConfig -> GenesisHashAlonzo
ncAlonzoGenesisHash NodeConfig
nodeConfig
      expectedShelleyHash :: Text
expectedShelleyHash = Hash Blake2b_256 ByteString -> Text
forall h a. Hash h a -> Text
Crypto.hashToTextAsHex (Hash Blake2b_256 ByteString -> Text)
-> Hash Blake2b_256 ByteString -> Text
forall a b. (a -> b) -> a -> b
$ GenesisHashShelley -> Hash Blake2b_256 ByteString
unGenesisHashShelley (GenesisHashShelley -> Hash Blake2b_256 ByteString)
-> GenesisHashShelley -> Hash Blake2b_256 ByteString
forall a b. (a -> b) -> a -> b
$ NodeConfig -> GenesisHashShelley
ncShelleyGenesisHash NodeConfig
nodeConfig
  Text
expectedConwayHash <- case NodeConfig -> Maybe GenesisHashConway
ncConwayGenesisHash NodeConfig
nodeConfig of
    Maybe GenesisHashConway
Nothing -> DebugCmdError -> ExceptT DebugCmdError IO Text
forall a. DebugCmdError -> ExceptT DebugCmdError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DebugCmdError -> ExceptT DebugCmdError IO Text)
-> DebugCmdError -> ExceptT DebugCmdError IO Text
forall a b. (a -> b) -> a -> b
$ String -> DebugCmdError
DebugNodeConfigNoConwayHashCmdError String
configFilePath
    Just GenesisHashConway
conwayGenesisHash -> Text -> ExceptT DebugCmdError IO Text
forall a. a -> ExceptT DebugCmdError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> ExceptT DebugCmdError IO Text)
-> Text -> ExceptT DebugCmdError IO Text
forall a b. (a -> b) -> a -> b
$ Hash Blake2b_256 ByteString -> Text
forall h a. Hash h a -> Text
Crypto.hashToTextAsHex (Hash Blake2b_256 ByteString -> Text)
-> Hash Blake2b_256 ByteString -> Text
forall a b. (a -> b) -> a -> b
$ GenesisHashConway -> Hash Blake2b_256 ByteString
unGenesisHashConway GenesisHashConway
conwayGenesisHash

  (GenesisData
_, Byron.GenesisHash Hash Raw
byronHash) <-
    (GenesisDataError -> DebugCmdError)
-> ExceptT GenesisDataError IO (GenesisData, GenesisHash)
-> ExceptT DebugCmdError IO (GenesisData, GenesisHash)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT (String -> GenesisDataError -> DebugCmdError
DebugNodeConfigGenesisDataCmdError String
byronGenFile) (ExceptT GenesisDataError IO (GenesisData, GenesisHash)
 -> ExceptT DebugCmdError IO (GenesisData, GenesisHash))
-> ExceptT GenesisDataError IO (GenesisData, GenesisHash)
-> ExceptT DebugCmdError IO (GenesisData, GenesisHash)
forall a b. (a -> b) -> a -> b
$
      String -> ExceptT GenesisDataError IO (GenesisData, GenesisHash)
forall (m :: * -> *).
(MonadError GenesisDataError m, MonadIO m) =>
String -> m (GenesisData, GenesisHash)
Byron.readGenesisData String
byronGenFile
  let actualByronHash :: Text
actualByronHash = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Hash Raw -> String
forall a. Show a => a -> String
show Hash Raw
byronHash
  Text
actualAlonzoHash <- Hash Blake2b_256 ByteString -> Text
forall h a. Hash h a -> Text
Crypto.hashToTextAsHex (Hash Blake2b_256 ByteString -> Text)
-> ExceptT DebugCmdError IO (Hash Blake2b_256 ByteString)
-> ExceptT DebugCmdError IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ExceptT DebugCmdError IO (Hash Blake2b_256 ByteString)
forall (m :: * -> *).
MonadIO m =>
String -> m (Hash Blake2b_256 ByteString)
Read.readShelleyOnwardsGenesisAndHash String
alonzoGenFile
  Text
actualShelleyHash <- Hash Blake2b_256 ByteString -> Text
forall h a. Hash h a -> Text
Crypto.hashToTextAsHex (Hash Blake2b_256 ByteString -> Text)
-> ExceptT DebugCmdError IO (Hash Blake2b_256 ByteString)
-> ExceptT DebugCmdError IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ExceptT DebugCmdError IO (Hash Blake2b_256 ByteString)
forall (m :: * -> *).
MonadIO m =>
String -> m (Hash Blake2b_256 ByteString)
Read.readShelleyOnwardsGenesisAndHash String
shelleyGenFile
  Text
actualConwayHash <- Hash Blake2b_256 ByteString -> Text
forall h a. Hash h a -> Text
Crypto.hashToTextAsHex (Hash Blake2b_256 ByteString -> Text)
-> ExceptT DebugCmdError IO (Hash Blake2b_256 ByteString)
-> ExceptT DebugCmdError IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ExceptT DebugCmdError IO (Hash Blake2b_256 ByteString)
forall (m :: * -> *).
MonadIO m =>
String -> m (Hash Blake2b_256 ByteString)
Read.readShelleyOnwardsGenesisAndHash String
conwayGenFile

  Bool -> ExceptT DebugCmdError IO () -> ExceptT DebugCmdError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
actualByronHash Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
expectedByronHash) (ExceptT DebugCmdError IO () -> ExceptT DebugCmdError IO ())
-> ExceptT DebugCmdError IO () -> ExceptT DebugCmdError IO ()
forall a b. (a -> b) -> a -> b
$
    DebugCmdError -> ExceptT DebugCmdError IO ()
forall a. DebugCmdError -> ExceptT DebugCmdError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DebugCmdError -> ExceptT DebugCmdError IO ())
-> DebugCmdError -> ExceptT DebugCmdError IO ()
forall a b. (a -> b) -> a -> b
$
      String -> String -> Text -> Text -> DebugCmdError
DebugNodeConfigWrongGenesisHashCmdError
        String
configFilePath
        String
byronGenFile
        Text
actualByronHash
        Text
expectedByronHash
  Bool -> ExceptT DebugCmdError IO () -> ExceptT DebugCmdError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
actualAlonzoHash Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
expectedAlonzoHash) (ExceptT DebugCmdError IO () -> ExceptT DebugCmdError IO ())
-> ExceptT DebugCmdError IO () -> ExceptT DebugCmdError IO ()
forall a b. (a -> b) -> a -> b
$
    DebugCmdError -> ExceptT DebugCmdError IO ()
forall a. DebugCmdError -> ExceptT DebugCmdError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DebugCmdError -> ExceptT DebugCmdError IO ())
-> DebugCmdError -> ExceptT DebugCmdError IO ()
forall a b. (a -> b) -> a -> b
$
      String -> String -> Text -> Text -> DebugCmdError
DebugNodeConfigWrongGenesisHashCmdError
        String
configFilePath
        String
alonzoGenFile
        Text
actualAlonzoHash
        Text
expectedAlonzoHash
  Bool -> ExceptT DebugCmdError IO () -> ExceptT DebugCmdError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
actualShelleyHash Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
expectedShelleyHash) (ExceptT DebugCmdError IO () -> ExceptT DebugCmdError IO ())
-> ExceptT DebugCmdError IO () -> ExceptT DebugCmdError IO ()
forall a b. (a -> b) -> a -> b
$
    DebugCmdError -> ExceptT DebugCmdError IO ()
forall a. DebugCmdError -> ExceptT DebugCmdError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DebugCmdError -> ExceptT DebugCmdError IO ())
-> DebugCmdError -> ExceptT DebugCmdError IO ()
forall a b. (a -> b) -> a -> b
$
      String -> String -> Text -> Text -> DebugCmdError
DebugNodeConfigWrongGenesisHashCmdError
        String
configFilePath
        String
shelleyGenFile
        Text
actualShelleyHash
        Text
expectedShelleyHash
  Bool -> ExceptT DebugCmdError IO () -> ExceptT DebugCmdError IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
actualConwayHash Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
expectedConwayHash) (ExceptT DebugCmdError IO () -> ExceptT DebugCmdError IO ())
-> ExceptT DebugCmdError IO () -> ExceptT DebugCmdError IO ()
forall a b. (a -> b) -> a -> b
$
    DebugCmdError -> ExceptT DebugCmdError IO ()
forall a. DebugCmdError -> ExceptT DebugCmdError IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (DebugCmdError -> ExceptT DebugCmdError IO ())
-> DebugCmdError -> ExceptT DebugCmdError IO ()
forall a b. (a -> b) -> a -> b
$
      String -> String -> Text -> Text -> DebugCmdError
DebugNodeConfigWrongGenesisHashCmdError
        String
configFilePath
        String
conwayGenFile
        Text
actualConwayHash
        Text
expectedConwayHash
 where
  configFilePath :: String
configFilePath = NodeConfigFile 'In -> String
forall content (direction :: FileDirection).
File content direction -> String
unFile NodeConfigFile 'In
configFile
  -- We make the genesis filepath relative to the node configuration file, like the node does:
  -- https://github.com/IntersectMBO/cardano-node/blob/9671e7b6a1b91f5a530722937949b86deafaad43/cardano-node/src/Cardano/Node/Configuration/POM.hs#L668
  -- Note that, if the genesis filepath is absolute, the node configuration file's directory is ignored (by property of </>)
  adjustFilepath :: String -> String
adjustFilepath String
f = String -> String
takeDirectory String
configFilePath String -> String -> String
</> String
f