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

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

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

import Cardano.CLI.Compatible.Exception
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.Foldable (for_)
import Data.Text qualified as Text
import Data.Yaml qualified as Yaml
import System.FilePath

runCheckNodeConfig :: CheckNodeConfigCmdArgs -> CIO e ()
runCheckNodeConfig :: forall e. CheckNodeConfigCmdArgs -> CIO e ()
runCheckNodeConfig (CheckNodeConfigCmdArgs NodeConfigFile 'In
configFile) = do
  NodeConfig
nodeConfig :: NodeConfig <- IO NodeConfig -> RIO e NodeConfig
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO NodeConfig -> RIO e NodeConfig)
-> IO NodeConfig -> RIO e 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 -> CIO e ()
forall e. NodeConfigFile 'In -> NodeConfig -> CIO e ()
checkNodeGenesisConfiguration NodeConfigFile 'In
configFile NodeConfig
nodeConfig
  IO () -> RIO e ()
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO e ()) -> IO () -> RIO e ()
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
  -> CIO e ()
checkNodeGenesisConfiguration :: forall e. NodeConfigFile 'In -> NodeConfig -> CIO e ()
checkNodeGenesisConfiguration NodeConfigFile 'In
configFile NodeConfig
nodeConfig = do
  let byronGenFile :: String
byronGenFile = File ByronGenesisConfig 'In -> String
forall content (direction :: FileDirection).
File content direction -> String
adjustFilepath (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 = File AlonzoGenesis 'In -> String
forall content (direction :: FileDirection).
File content direction -> String
adjustFilepath (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 = File ShelleyGenesisConfig 'In -> String
forall content (direction :: FileDirection).
File content direction -> String
adjustFilepath (File ShelleyGenesisConfig 'In -> String)
-> File ShelleyGenesisConfig 'In -> String
forall a b. (a -> b) -> a -> b
$ NodeConfig -> File ShelleyGenesisConfig 'In
ncShelleyGenesisFile NodeConfig
nodeConfig
      conwayGenFile :: String
conwayGenFile = File ConwayGenesisConfig 'In -> String
forall content (direction :: FileDirection).
File content direction -> String
adjustFilepath (File ConwayGenesisConfig 'In -> String)
-> File ConwayGenesisConfig 'In -> String
forall a b. (a -> b) -> a -> b
$ NodeConfig -> File ConwayGenesisConfig 'In
ncConwayGenesisFile NodeConfig
nodeConfig

  IO () -> RIO e ()
forall a. IO a -> RIO e a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO e ()) -> IO () -> RIO e ()
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 mExpectedByronHash :: Maybe Text
mExpectedByronHash = GenesisHashByron -> Text
unGenesisHashByron (GenesisHashByron -> Text) -> Maybe GenesisHashByron -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeConfig -> Maybe GenesisHashByron
ncByronGenesisHash NodeConfig
nodeConfig
      mExpectedAlonzoHash :: Maybe Text
mExpectedAlonzoHash = Hash Blake2b_256 ByteString -> Text
forall h a. Hash h a -> Text
Crypto.hashToTextAsHex (Hash Blake2b_256 ByteString -> Text)
-> (GenesisHashAlonzo -> Hash Blake2b_256 ByteString)
-> GenesisHashAlonzo
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenesisHashAlonzo -> Hash Blake2b_256 ByteString
unGenesisHashAlonzo (GenesisHashAlonzo -> Text)
-> Maybe GenesisHashAlonzo -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeConfig -> Maybe GenesisHashAlonzo
ncAlonzoGenesisHash NodeConfig
nodeConfig
      mExpectedShelleyHash :: Maybe Text
mExpectedShelleyHash = Hash Blake2b_256 ByteString -> Text
forall h a. Hash h a -> Text
Crypto.hashToTextAsHex (Hash Blake2b_256 ByteString -> Text)
-> (GenesisHashShelley -> Hash Blake2b_256 ByteString)
-> GenesisHashShelley
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenesisHashShelley -> Hash Blake2b_256 ByteString
unGenesisHashShelley (GenesisHashShelley -> Text)
-> Maybe GenesisHashShelley -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeConfig -> Maybe GenesisHashShelley
ncShelleyGenesisHash NodeConfig
nodeConfig
      mExpectedConwayHash :: Maybe Text
mExpectedConwayHash = Hash Blake2b_256 ByteString -> Text
forall h a. Hash h a -> Text
Crypto.hashToTextAsHex (Hash Blake2b_256 ByteString -> Text)
-> (GenesisHashConway -> Hash Blake2b_256 ByteString)
-> GenesisHashConway
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenesisHashConway -> Hash Blake2b_256 ByteString
unGenesisHashConway (GenesisHashConway -> Text)
-> Maybe GenesisHashConway -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NodeConfig -> Maybe GenesisHashConway
ncConwayGenesisHash NodeConfig
nodeConfig

  (GenesisData
_, Byron.GenesisHash Hash Raw
byronHash) <- ExceptT GenesisDataError IO (GenesisData, GenesisHash)
-> RIO e (GenesisData, GenesisHash)
forall e (m :: * -> *) a.
(HasCallStack, MonadIO m, Show e, Typeable e, Error e) =>
ExceptT e IO a -> m a
fromExceptTCli (ExceptT GenesisDataError IO (GenesisData, GenesisHash)
 -> RIO e (GenesisData, GenesisHash))
-> ExceptT GenesisDataError IO (GenesisData, GenesisHash)
-> RIO e (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)
-> RIO e (Hash Blake2b_256 ByteString) -> RIO e Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> RIO e (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)
-> RIO e (Hash Blake2b_256 ByteString) -> RIO e Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> RIO e (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)
-> RIO e (Hash Blake2b_256 ByteString) -> RIO e Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> RIO e (Hash Blake2b_256 ByteString)
forall (m :: * -> *).
MonadIO m =>
String -> m (Hash Blake2b_256 ByteString)
Read.readShelleyOnwardsGenesisAndHash String
conwayGenFile

  -- check only hashes which were specified for the genesis
  [(Maybe Text, Text, String)]
-> ((Maybe Text, Text, String) -> RIO e ()) -> RIO e ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_
    [ (Maybe Text
mExpectedByronHash, Text
actualByronHash, String
byronGenFile)
    , (Maybe Text
mExpectedShelleyHash, Text
actualShelleyHash, String
shelleyGenFile)
    , (Maybe Text
mExpectedAlonzoHash, Text
actualAlonzoHash, String
alonzoGenFile)
    , (Maybe Text
mExpectedConwayHash, Text
actualConwayHash, String
conwayGenFile)
    ]
    (((Maybe Text, Text, String) -> RIO e ()) -> RIO e ())
-> ((Maybe Text, Text, String) -> RIO e ()) -> RIO e ()
forall a b. (a -> b) -> a -> b
$ \(Maybe Text
mExpected, Text
actual, String
genFile) ->
      Maybe Text -> (Text -> RIO e ()) -> RIO e ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Text
mExpected ((Text -> RIO e ()) -> RIO e ()) -> (Text -> RIO e ()) -> RIO e ()
forall a b. (a -> b) -> a -> b
$ \Text
expected ->
        Bool -> RIO e () -> RIO e ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
actual Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
expected) (RIO e () -> RIO e ()) -> RIO e () -> RIO e ()
forall a b. (a -> b) -> a -> b
$
          DebugCmdError -> RIO e ()
forall e (m :: * -> *) a.
(HasCallStack, Show e, Typeable e, Error e, MonadIO m) =>
e -> m a
throwCliError (DebugCmdError -> RIO e ()) -> DebugCmdError -> RIO e ()
forall a b. (a -> b) -> a -> b
$
            String -> String -> Text -> Text -> DebugCmdError
DebugNodeConfigWrongGenesisHashCmdError String
configFilePath String
genFile Text
actual Text
expected
 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 :: File content direction -> String
adjustFilepath (File String
f) = String -> String
takeDirectory String
configFilePath String -> String -> String
</> String
f