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

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

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

import           Cardano.CLI.Commands.Debug.CheckNodeConfiguration
import qualified Cardano.CLI.Read as Read
import           Cardano.CLI.Types.Errors.DebugCmdError
import qualified Cardano.Crypto.Hash as Crypto

import           Control.Monad
import qualified Data.Text as Text
import qualified Data.Yaml 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