diff --git a/bench/tx-generator/src/Cardano/TxGenerator/Setup/NodeConfig.hs b/bench/tx-generator/src/Cardano/TxGenerator/Setup/NodeConfig.hs index 8e78199c68b..0f42f441265 100644 --- a/bench/tx-generator/src/Cardano/TxGenerator/Setup/NodeConfig.hs +++ b/bench/tx-generator/src/Cardano/TxGenerator/Setup/NodeConfig.hs @@ -11,20 +11,18 @@ module Cardano.TxGenerator.Setup.NodeConfig import Cardano.Api (BlockType (..), ProtocolInfoArgs (..)) import qualified Cardano.Ledger.Api.Transition as Ledger (tcShelleyGenesisL) +import Cardano.Node.Configuration.Adapter (nodeConfigurationFromFile) import Cardano.Node.Configuration.POM -import Cardano.Node.Handlers.Shutdown (ShutdownConfig (..)) import Cardano.Node.Protocol.Cardano import Cardano.Node.Protocol.Types (SomeConsensusProtocol (..)) -import Cardano.Node.Types (ConfigYamlFilePath (..), GenesisFile, KESSource (..), - NodeProtocolConfiguration (..), NodeShelleyProtocolConfiguration (..), - ProtocolFilepaths (..)) +import Cardano.Node.Types (GenesisFile, NodeProtocolConfiguration (..), + NodeShelleyProtocolConfiguration (..)) import Cardano.TxGenerator.Types import qualified Ouroboros.Consensus.Cardano.Node as Consensus import Control.Applicative (Const (Const), getConst) import Control.Monad.Trans.Except (runExceptT) import Data.Bifunctor (first) -import Data.Monoid -- | extract genesis from a Cardano protocol @@ -53,29 +51,11 @@ mkConsensusProtocol nodeConfig = <$> runExceptT (mkSomeConsensusProtocolCardano byronConfig shelleyConfig alonzoConfig conwayConfig dijkstraConfig hardforkConfig checkpointsConfig Nothing) -- | Creates a NodeConfiguration from a config file; --- the result is devoid of any keys/credentials +-- the result is devoid of any keys/credentials. +-- +-- The configuration is parsed and resolved through the @cardano-config@ package +-- (via "Cardano.Node.Configuration.Adapter"), applying no CLI overrides, so the +-- credential and socket paths are left unset. mkNodeConfig :: FilePath -> IO (Either TxGenError NodeConfiguration) -mkNodeConfig configFp_ - = do - configYamlPc <- parseNodeConfigurationFP . Just $ configFp - return - $ first (TxGenError . ("mkNodeConfig: " ++)) - $! makeNodeConfiguration (configYamlPc <> filesPc) - where - configFp = ConfigYamlFilePath configFp_ - - filesPc :: PartialNodeConfiguration - filesPc = defaultPartialNodeConfiguration - { pncProtocolFiles = Last . Just $ - ProtocolFilepaths - { byronCertFile = Just "" - , byronKeyFile = Just "" - , shelleyKESSource = Just (KESKeyFilePath "") - , shelleyVRFFile = Just "" - , shelleyCertFile = Just "" - , shelleyBulkCredsFile = Just "" - } - , pncValidateDB = Last $ Just False - , pncShutdownConfig = Last $ Just $ ShutdownConfig Nothing Nothing - , pncConfigFile = Last $ Just configFp - } +mkNodeConfig configFp = + first (TxGenError . ("mkNodeConfig: " ++)) <$> nodeConfigurationFromFile configFp diff --git a/cabal.project b/cabal.project index 72751dd7d92..5abcd01df7a 100644 --- a/cabal.project +++ b/cabal.project @@ -182,3 +182,11 @@ source-repository-package location: https://github.com/f-f/ekg-forward tag: b24b3aba2806ce223c62f8ce3e267ec92dcc52e2 --sha256: sha256-s5Hxxm04HmFVmdBjAnFEsJEhTqr5Z/uiB4K1s2VaVwE= + +source-repository-package + type: git + location: https://github.com/IntersectMBO/cardano-base + tag: 8761e5c7ad09935376ec440cf33919b7544b5975 + --sha256: sha256-uMExJzjeRB3DZi27zBgfdXArxiNen4e9poavE58atuI= + subdir: + cardano-config diff --git a/cardano-node-capi/cardano-node-capi.cabal b/cardano-node-capi/cardano-node-capi.cabal index d50d59e6e1e..2be5a5f3c38 100644 --- a/cardano-node-capi/cardano-node-capi.cabal +++ b/cardano-node-capi/cardano-node-capi.cabal @@ -21,8 +21,7 @@ library import: project-config exposed-modules: Node build-depends: base >= 4.14 && < 5 - , aeson - , bytestring + , cardano-config , cardano-node , optparse-applicative hs-source-dirs: src diff --git a/cardano-node-capi/src/Node.hs b/cardano-node-capi/src/Node.hs index 2db6b7730b7..d9277084c57 100644 --- a/cardano-node-capi/src/Node.hs +++ b/cardano-node-capi/src/Node.hs @@ -1,11 +1,8 @@ module Node where -import Cardano.Node.Parsers (nodeCLIParser, parserHelpHeader, parserHelpOptions, - renderHelpDoc) +import qualified Cardano.Configuration as CC import Cardano.Node.Run (runNode) -import Data.Aeson (eitherDecodeStrict) -import Data.ByteString.Char8 (pack) import Options.Applicative import Foreign.C (CString, peekCString) @@ -19,10 +16,13 @@ foreign export ccall "runNode" crunNode :: Int -> Ptr CString -> IO () crunNode :: Int -> Ptr CString -> IO () crunNode argc argv = peekArray argc argv >>= mapM peekCString >>= \args -> case execParserPure pref opts args of - Success pnc -> runNode pnc + Success cli -> runNode cli Failure f -> print f CompletionInvoked _ -> putStrLn "Completion Invoked?" where pref = prefs showHelpOnEmpty - opts = info nodeCLIParser + opts = info (nodeRunParser <**> helper) ( fullDesc <> progDesc "Start node of the Cardano blockchain." ) + nodeRunParser = + subparser $ + command "run" (info (CC.parseCliArgs <**> helper) (progDesc "Run the node.")) diff --git a/cardano-node-chairman/app/Cardano/Chairman/Commands/Run.hs b/cardano-node-chairman/app/Cardano/Chairman/Commands/Run.hs index a7e68fdd855..747f69c6f6d 100644 --- a/cardano-node-chairman/app/Cardano/Chairman/Commands/Run.hs +++ b/cardano-node-chairman/app/Cardano/Chairman/Commands/Run.hs @@ -13,8 +13,8 @@ import qualified Cardano.Api as Api import Cardano.Chairman (chairmanTest) import Cardano.Ledger.BaseTypes (unNonZero) -import Cardano.Node.Configuration.POM (PartialNodeConfiguration (..), - parseNodeConfigurationFP) +import Cardano.Node.Configuration.Adapter (nodeConfigurationFromFile) +import Cardano.Node.Configuration.POM (NodeConfiguration (..)) import Cardano.Node.Protocol import Cardano.Node.Types import Cardano.Prelude (ConvertText (..)) @@ -25,7 +25,6 @@ import Ouroboros.Consensus.Node.ProtocolInfo import Control.Monad.Class.MonadTime.SI (DiffTime) import Control.Tracer (Tracer, mkTracer, stdoutTracer, traceWith) -import Data.Monoid (Last (..)) import qualified Data.Time.Clock as DTC import Options.Applicative import qualified Options.Applicative as Opt @@ -98,13 +97,13 @@ run RunOpts , caConfigYaml } = do - configYamlPc <- liftIO . parseNodeConfigurationFP $ Just caConfigYaml + nodeConfig <- liftIO (nodeConfigurationFromFile (unConfigPath caConfigYaml)) + >>= either + (\err -> error $ "Error in creating the NodeConfiguration from " + <> unConfigPath caConfigYaml <> ": " <> err) + return - ptclConfig <- case getProtocolConfiguration configYamlPc of - Nothing -> - error $ "Node protocol configuration was not specified "<> - "in Config yaml filepath: " <> unConfigPath caConfigYaml - Just ptclConfig -> return ptclConfig + let ptclConfig = ncProtocolConfig nodeConfig eitherSomeProtocol <- runExceptT $ mkConsensusProtocol ptclConfig Nothing @@ -134,17 +133,11 @@ run RunOpts return () where getConsensusMode :: SecurityParam -> NodeProtocolConfiguration -> ConsensusModeParams - getConsensusMode (SecurityParam k) ncProtocolConfig = - case ncProtocolConfig of + getConsensusMode (SecurityParam k) ncProtocolConfig' = + case ncProtocolConfig' of NodeProtocolConfigurationCardano{} -> CardanoModeParams $ EpochSlots $ unNonZero k - getProtocolConfiguration - :: PartialNodeConfiguration - -> Maybe NodeProtocolConfiguration - getProtocolConfiguration PartialNodeConfiguration{pncProtocolConfig} = - getLast pncProtocolConfig - timed :: Tracer IO a -> Tracer IO a timed tr = mkTracer $ \a -> do ts <- DTC.getCurrentTime diff --git a/cardano-node/app/cardano-node.hs b/cardano-node/app/cardano-node.hs index 563193bd652..12779ace684 100644 --- a/cardano-node/app/cardano-node.hs +++ b/cardano-node/app/cardano-node.hs @@ -4,23 +4,20 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} +import qualified Cardano.Configuration as CC import qualified Cardano.Crypto.Init as Crypto import Cardano.Git.Rev (gitRev) -import Cardano.Node.Configuration.POM (PartialNodeConfiguration (..)) import Cardano.Node.Handlers.TopLevel -import Cardano.Node.Parsers (nodeCLIParser) import Cardano.Node.Run (runNode) import Cardano.Node.Tracing.Documentation (TraceDocumentationCmd (..), parseTraceDocumentationCmd, runTraceDocumentationCmd) -import Data.Monoid (Last (getLast)) import qualified Data.Text as Text import qualified Data.Text.IO as Text import Data.Version (showVersion) import Options.Applicative import qualified Options.Applicative as Opt import System.Info (arch, compilerName, compilerVersion, os) -import System.IO (hPutStrLn, stderr) import Paths_cardano_node (version) @@ -32,28 +29,16 @@ main = do cmd <- Opt.customExecParser p opts case cmd of - RunCmd args -> do - warnIfSet args pncMaybeMempoolCapacityOverride "mempool-capacity-override" "MempoolCapacityBytesOverride" - runNode args + RunCmd args -> runNode args TraceDocumentation tdc -> runTraceDocumentationCmd tdc VersionCmd -> runVersionCommand where p = Opt.prefs Opt.showHelpOnEmpty - warnIfSet :: PartialNodeConfiguration -> (PartialNodeConfiguration -> Last a) -> String -> String -> IO () - warnIfSet args f name key = - maybe - (pure ()) - (\_ -> hPutStrLn stderr $ "WARNING: Option --" ++ name ++ " was set via CLI flags.\ - \ This CLI flag will be removed in upcoming node releases.\ - \ Please, set this configuration option in the configuration file instead with key " ++ key ++ ".") - $ getLast - $ f args - opts :: Opt.ParserInfo Command opts = - Opt.info (fmap RunCmd nodeCLIParser + Opt.info (fmap RunCmd nodeRunParser <|> fmap TraceDocumentation parseTraceDocumentationCmd <|> parseVersionCmd <**> helper) @@ -62,8 +47,11 @@ main = do Opt.progDesc "Start node of the Cardano blockchain." ) +-- | The node's CLI, parsed by @cardano-config@, under the @run@ subcommand. +nodeRunParser :: Parser CC.CliArgs +nodeRunParser = Opt.subparser $ command' "run" "Run the node." CC.parseCliArgs -data Command = RunCmd PartialNodeConfiguration +data Command = RunCmd CC.CliArgs | TraceDocumentation TraceDocumentationCmd | VersionCmd diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal index 7203af08ef3..07224a1adcb 100644 --- a/cardano-node/cardano-node.cabal +++ b/cardano-node/cardano-node.cabal @@ -59,7 +59,8 @@ library hs-source-dirs: src - exposed-modules: Cardano.Node.Configuration.NodeAddress + exposed-modules: Cardano.Node.Configuration.Adapter + Cardano.Node.Configuration.NodeAddress Cardano.Node.Configuration.POM Cardano.Node.Configuration.LedgerDB Cardano.Node.Configuration.Socket @@ -67,7 +68,6 @@ library Cardano.Node.Handlers.Shutdown Cardano.Node.Handlers.TopLevel Cardano.Node.Orphans - Cardano.Node.Parsers Cardano.Node.Pretty Cardano.Node.Protocol Cardano.Node.Protocol.Alonzo @@ -124,6 +124,7 @@ library , base16-bytestring , bytestring , cardano-api ^>= 11.3 + , cardano-config , cardano-data , cardano-crypto-class ^>=2.5 , cardano-crypto-wrapper @@ -188,7 +189,6 @@ library , transformers , transformers-except , typed-protocols:{typed-protocols, stateful} >= 1.2 - , yaml executable cardano-node import: project-config @@ -206,6 +206,7 @@ executable cardano-node autogen-modules: Paths_cardano_node build-depends: base + , cardano-config , cardano-crypto-class , cardano-git-rev , cardano-node diff --git a/cardano-node/src/Cardano/Node/Configuration/Adapter.hs b/cardano-node/src/Cardano/Node/Configuration/Adapter.hs new file mode 100644 index 00000000000..d8473f1049f --- /dev/null +++ b/cardano-node/src/Cardano/Node/Configuration/Adapter.hs @@ -0,0 +1,453 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Adapter from the @cardano-config@ package's resolved configuration +-- ('CC.NodeConfiguration') to the node's existing 'PartialNodeConfiguration'. +-- +-- The intent is that the node's entrypoint becomes: +-- +-- @ +-- file <- CC.parseConfigurationFiles (CC.configFilePath cli) +-- let ccnc = CC.resolveConfiguration cli file +-- cfgDir = takeDirectory (CC.configFilePath cli) +-- makeNodeConfiguration (defaultPartialNodeConfiguration <> fromCardanoConfig cfgDir ccnc) +-- @ +-- +-- We deliberately target 'PartialNodeConfiguration' (not the fully-resolved +-- 'NodeConfiguration') so that all of the node's defaulting and validation +-- logic in 'makeNodeConfiguration' is reused verbatim. Whenever +-- @cardano-config@ has no value for a field we leave it as 'mempty' / @Last +-- Nothing@ so the node default applies. +-- +-- NOTE on file paths: genesis and checkpoint files are always sourced from the +-- configuration file and, as in the legacy parser, are resolved relative to the +-- configuration file's directory (the @configDir@ argument). Credential, +-- database and socket paths come (mostly) from the CLI and are left as given, +-- i.e. relative to the current working directory — again matching the legacy +-- 'parseNodeConfigurationFP' / 'AdjustFilePaths' behaviour. +module Cardano.Node.Configuration.Adapter + ( fromCardanoConfig + , nodeConfigurationFromCli + , nodeConfigurationFromFile + , cliArgsFromConfigFile + ) where + +import qualified Cardano.Configuration as CC +import qualified Cardano.Configuration.CliArgs as CCCli +import qualified Cardano.Configuration.File.Consensus as CCCon +import qualified Cardano.Configuration.File.Network as CCNet +import qualified Cardano.Configuration.File.Storage as CCSto + +import Cardano.Api (File (..)) + +import Cardano.Crypto (RequiresNetworkMagic (..)) +import Cardano.Network.ConsensusMode (ConsensusMode (..)) +import Cardano.Network.PeerSelection (NumberOfBigLedgerPeers (..)) +import Cardano.Node.Configuration.LedgerDB (LedgerDbConfiguration (..), + LedgerDbSelectorFlag (..), noDeprecatedOptions) +import Cardano.Node.Configuration.NodeAddress (NodeHostIPv4Address (..), + NodeHostIPv6Address (..)) +import Cardano.Node.Configuration.POM (NodeConfiguration, + PartialNodeConfiguration (..), ResponderCoreAffinityPolicy (..), + defaultPartialNodeConfiguration, makeNodeConfiguration) +import Cardano.Node.Configuration.Socket (SocketConfig (..)) +import Cardano.Node.Handlers.Shutdown (ShutdownConfig (..), ShutdownOn (..)) +import Cardano.Node.Types +import Cardano.Rpc.Server.Config (RpcConfigF (..)) + +import Cardano.Slotting.Block (BlockNo (..)) +import Cardano.Slotting.Slot (EpochNo (..), SlotNo (..)) + +import qualified Cardano.Logging.Types as Net + +import Ouroboros.Consensus.Ledger.SupportsMempool (ByteSize32 (..)) +import Ouroboros.Consensus.Mempool (MempoolCapacityBytesOverride (..)) +import Ouroboros.Consensus.Node (NodeDatabasePaths (..)) +import qualified Ouroboros.Consensus.Node.Genesis as Genesis +import Ouroboros.Consensus.Storage.LedgerDB.Args (QueryBatchSize (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (NumOfDiskSnapshots (..), + SnapshotFrequency (..), SnapshotFrequencyArgs (..), + SnapshotPolicyArgs (..), defaultSnapshotPolicyArgs) +import Ouroboros.Consensus.Util.Args (OverrideOrDefault (..)) +-- These three are re-exported (unqualified) from +-- @Ouroboros.Network.Diffusion.Configuration@, exactly as +-- 'Cardano.Node.Configuration.POM' imports them. +import Ouroboros.Network.Diffusion.Configuration (AcceptedConnectionsLimit (..), + DiffusionMode (..), PeerSharing (..)) +import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TxSubmissionInitDelay (..), + TxSubmissionLogicVersion (..)) + +import Cardano.Ledger.BaseTypes.NonZero (nonZero) + +import Control.Exception (displayException) +import Data.Bifunctor (first) +import Data.Functor.Identity (runIdentity) +import Data.Maybe (fromMaybe) +import Data.Monoid (Last (..)) +import Data.Time.Clock (secondsToDiffTime) +import GHC.Stack (HasCallStack) +import System.FilePath (takeDirectory, ()) + +-- | Parse the configuration file(s) referenced by the CLI arguments, resolve +-- them through @cardano-config@, and build the node's 'NodeConfiguration' +-- (applying the node's own defaults and validation via 'makeNodeConfiguration'). +-- +-- Returns 'Left' with a human-readable message on a resolution or validation +-- error; an I/O error while reading the configuration file is thrown. +nodeConfigurationFromCli :: HasCallStack => CC.CliArgs -> IO (Either String NodeConfiguration) +nodeConfigurationFromCli cli = do + file <- CC.parseConfigurationFiles (CCCli.configFilePath cli) + pure $ do + ccnc <- first displayException (CC.resolveConfiguration cli file) + let cfgDir = takeDirectory (CCCli.configFilePath cli) + makeNodeConfiguration (defaultPartialNodeConfiguration <> fromCardanoConfig cfgDir ccnc) + +-- | Build the node's 'NodeConfiguration' from just a configuration file path, +-- applying no CLI overrides. For tools (e.g. the chairman, tx-generator) that +-- only need the configuration file's contents. +nodeConfigurationFromFile :: HasCallStack => FilePath -> IO (Either String NodeConfiguration) +nodeConfigurationFromFile = nodeConfigurationFromCli . cliArgsFromConfigFile + +-- | The default topology path used by @cardano-config@'s CLI parser, applied +-- when a tool constructs 'CC.CliArgs' without parsing a @--topology@ flag. +defaultTopologyFile :: FilePath +defaultTopologyFile = "configuration/cardano/mainnet-topology.json" + +-- | Build a 'CC.CliArgs' that supplies only the configuration file path, +-- leaving every other option unset. For tools that only need the configuration +-- file's contents, with no CLI overrides. +cliArgsFromConfigFile :: FilePath -> CC.CliArgs +cliArgsFromConfigFile fp = + CCCli.CliArgs + { CCCli.configFilePath = fp + , CCCli.topologyFile = defaultTopologyFile + , CCCli.databasePathCLI = Nothing + , CCCli.validateDatabase = False + , CCCli.socketPath = Nothing + , CCCli.credentials = CCCli.Credentials Nothing Nothing Nothing Nothing Nothing Nothing + , CCCli.startAsNonProducingNode = Nothing + , CCCli.hostAddr = Nothing + , CCCli.hostIPv6Addr = Nothing + , CCCli.port = Nothing + , CCCli.tracerSocket = Nothing + , CCCli.shutdownIPC = Nothing + , CCCli.shutdownOnTarget = Nothing + , CCCli.enableRpcCLI = Nothing + , CCCli.rpcSocketPathCLI = Nothing + } + +-- | Map a resolved @cardano-config@ configuration onto a +-- 'PartialNodeConfiguration'. Combine with +-- @defaultPartialNodeConfiguration <> _@ and feed to @makeNodeConfiguration@. +fromCardanoConfig :: FilePath -> CC.NodeConfiguration -> PartialNodeConfiguration +fromCardanoConfig configDir ccnc = + PartialNodeConfiguration + { pncConfigFile = Last . Just . ConfigYamlFilePath $ CC.configFilePath ccnc + , pncTopologyFile = Last . Just . TopologyFile $ CC.topologyFile ccnc + , pncDatabaseFile = Last . Just . fromDbPaths . runIdentity $ CC.databasePath storage + , pncValidateDB = Last . Just $ CC.validateDatabase ccnc + , pncProtocolFiles = Last . Just $ fromCredentials (CC.credentials ccnc) + , pncShutdownConfig = Last . Just $ ShutdownConfig (CC.shutdownIPC ccnc) (fromShutdownOn <$> CC.shutdownOnTarget ccnc) + , pncSocketConfig = Last . Just $ socketConfig + , pncStartAsNonProducingNode = Last . Just . runIdentity $ CC.startAsNonProducingNode protocol + + -- Protocol-specific parameters + , pncProtocolConfig = Last . Just $ protocolConfig + + -- Modes + , pncDiffusionMode = Last . Just . fromDiffusionMode . runIdentity $ CCNet.diffusionMode net + , pncExperimentalProtocolsEnabled = Last . Just . runIdentity $ CCNet.experimentalProtocolsEnabled net + + -- BlockFetch + , pncMaxConcurrencyBulkSync = Last . Just . MaxConcurrencyBulkSync . runIdentity $ CCNet.maxConcurrencyBulkSync net + , pncMaxConcurrencyDeadline = Last . Just . MaxConcurrencyDeadline . runIdentity $ CCNet.maxConcurrencyDeadline net + + -- Tracing forwarder socket (CLI only) + , pncTraceForwardSocket = Last $ fromTracerConnection <$> CC.tracerSocket ccnc + + -- Mempool + , pncMaybeMempoolCapacityOverride = + Last $ (MempoolCapacityBytesOverride . ByteSize32 . fromIntegral) + <$> CC.mempoolCapacityOverride mempool + , pncMempoolTimeoutSoft = Last $ CC.mempoolTimeoutSoft mempool + , pncMempoolTimeoutHard = Last $ CC.mempoolTimeoutHard mempool + , pncMempoolTimeoutCapacity = Last $ CC.mempoolTimeoutCapacity mempool + + -- LedgerDB + , pncLedgerDbConfig = Last . Just . fromLedgerDb . runIdentity $ CC.ledgerDbConfiguration storage + + -- Network timeouts + , pncProtocolIdleTimeout = Last . Just . runIdentity $ CCNet.protocolIdleTimeout net + , pncTimeWaitTimeout = Last . Just . runIdentity $ CCNet.timeWaitTimeout net + , pncEgressPollInterval = Last . Just . runIdentity $ CCNet.egressPollInterval net + , pncChainSyncIdleTimeout = Last . Just . runIdentity $ CCNet.chainSyncIdleTimeout net + + -- AcceptedConnectionsLimit + , pncAcceptedConnectionsLimit = Last . Just . fromAcceptedConnectionsLimit . runIdentity $ CCNet.acceptedConnectionsLimit net + + -- P2P governor targets (deadline) + , pncDeadlineTargetOfRootPeers = Last $ CCNet.deadlineTargetOfRootPeers net + , pncDeadlineTargetOfKnownPeers = Last $ CCNet.deadlineTargetOfKnownPeers net + , pncDeadlineTargetOfEstablishedPeers = Last $ CCNet.deadlineTargetOfEstablishedPeers net + , pncDeadlineTargetOfActivePeers = Last $ CCNet.deadlineTargetOfActivePeers net + , pncDeadlineTargetOfKnownBigLedgerPeers = Last $ CCNet.deadlineTargetOfKnownBigLedgerPeers net + , pncDeadlineTargetOfEstablishedBigLedgerPeers = Last $ CCNet.deadlineTargetOfEstablishedBigLedgerPeers net + , pncDeadlineTargetOfActiveBigLedgerPeers = Last $ CCNet.deadlineTargetOfActiveBigLedgerPeers net + + -- P2P governor targets (sync) + , pncSyncTargetOfRootPeers = Last . Just . runIdentity $ CCNet.syncTargetOfRootPeers net + , pncSyncTargetOfKnownPeers = Last . Just . runIdentity $ CCNet.syncTargetOfKnownPeers net + , pncSyncTargetOfEstablishedPeers = Last . Just . runIdentity $ CCNet.syncTargetOfEstablishedPeers net + , pncSyncTargetOfActivePeers = Last . Just . runIdentity $ CCNet.syncTargetOfActivePeers net + , pncSyncTargetOfKnownBigLedgerPeers = Last . Just . runIdentity $ CCNet.syncTargetOfKnownBigLedgerPeers net + , pncSyncTargetOfEstablishedBigLedgerPeers = Last . Just . runIdentity $ CCNet.syncTargetOfEstablishedBigLedgerPeers net + , pncSyncTargetOfActiveBigLedgerPeers = Last . Just . runIdentity $ CCNet.syncTargetOfActiveBigLedgerPeers net + + , pncMinBigLedgerPeersForTrustedState = + Last . Just . NumberOfBigLedgerPeers . runIdentity $ CCNet.minBigLedgerPeersForTrustedState net + + -- Consensus mode / Genesis + , pncConsensusMode = Last . Just $ consensusMode + , pncGenesisConfigFlags = Last genesisConfigFlags + + -- Peer sharing + , pncPeerSharing = Last $ fromPeerSharing <$> CCNet.peerSharing net + + , pncResponderCoreAffinityPolicy = + Last . Just . fromResponderCoreAffinity . runIdentity $ CCNet.responderCoreAffinityPolicy net + + , pncTxSubmissionLogicVersion = Last $ fromTxSubmissionLogicVersion (runIdentity (CCNet.txSubmissionLogicVersion net)) + , pncTxSubmissionInitDelay = Last . Just . TxSubmissionInitDelay . runIdentity $ CCNet.txSubmissionInitDelay net + + -- gRPC + , pncRpcConfig = rpcConfig + } + where + storage = CC.storageConfiguration ccnc + consensus = CC.consensusConfiguration ccnc + protocol = CC.protocolConfiguration ccnc + net = CC.networkConfiguration ccnc + testing = CC.testingConfiguration ccnc + mempool = CC.mempoolConfiguration ccnc + lcc = CC.localConnectionsConfig ccnc + + socketConfig = + SocketConfig + (Last $ NodeHostIPv4Address <$> CC.hostAddr ccnc) + (Last $ NodeHostIPv6Address <$> CC.hostIPv6Addr ccnc) + (Last $ CC.port ccnc) + (Last $ File <$> CCNet.socketPath lcc) + + rpcConfig = + RpcConfig + (Last . Just . runIdentity $ CCNet.enableRpc lcc) + (Last $ File <$> CCNet.rpcSocketPath lcc) + mempty + + -- The resolved consensus mode also drives whether the (separate) genesis + -- config flags field is populated. Mirrors the node's split: ConsensusMode + -- (Praos|Genesis) lives in one field, the low-level flags in another. + (consensusMode, genesisConfigFlags) = + case runIdentity (CC.getConsensusConfiguration consensus) of + CCCon.PraosMode -> (PraosMode, Nothing) + CCCon.GenesisMode flags -> (GenesisMode, Just (fromGenesisConfigFlags flags)) + + -- Genesis files always come from the configuration file and are resolved + -- relative to its directory (matching the legacy parser). + genesisFile = toGenesisFile configDir + + protocolConfig = + NodeProtocolConfigurationCardano + (fromByron configDir (CC.byronGenesis protocol)) + (NodeShelleyProtocolConfiguration (genesisFile (CC.shelleyGenesis protocol)) (toGenesisHash (CC.shelleyGenesis protocol))) + (NodeAlonzoProtocolConfiguration (genesisFile (CC.alonzoGenesis protocol)) (toGenesisHash (CC.alonzoGenesis protocol))) + (NodeConwayProtocolConfiguration (genesisFile (CC.conwayGenesis protocol)) (toGenesisHash (CC.conwayGenesis protocol))) + dijkstra + hardFork + checkpoints + + -- Dijkstra is only wired in when the experimental eras are enabled, and its + -- genesis file lives under the Testing component in cardano-config. + dijkstra + | runIdentity (CC.experimentalHardForksEnabled testing) + , Just h <- CC.experimentalGenesis testing + = Just $ NodeDijkstraProtocolConfiguration (genesisFile h) (toGenesisHash h) + | otherwise = Nothing + + hardFork = + NodeHardForkProtocolConfiguration + { npcExperimentalHardForksEnabled = runIdentity (CC.experimentalHardForksEnabled testing) + , npcTestShelleyHardForkAtEpoch = EpochNo <$> CC.testShelleyHardForkAtEpoch testing + , npcTestShelleyHardForkAtVersion = CC.testShelleyHardForkAtVersion testing + , npcTestAllegraHardForkAtEpoch = EpochNo <$> CC.testAllegraHardForkAtEpoch testing + , npcTestAllegraHardForkAtVersion = CC.testAllegraHardForkAtVersion testing + , npcTestMaryHardForkAtEpoch = EpochNo <$> CC.testMaryHardForkAtEpoch testing + , npcTestMaryHardForkAtVersion = CC.testMaryHardForkAtVersion testing + , npcTestAlonzoHardForkAtEpoch = EpochNo <$> CC.testAlonzoHardForkAtEpoch testing + , npcTestAlonzoHardForkAtVersion = CC.testAlonzoHardForkAtVersion testing + , npcTestBabbageHardForkAtEpoch = EpochNo <$> CC.testBabbageHardForkAtEpoch testing + , npcTestBabbageHardForkAtVersion = CC.testBabbageHardForkAtVersion testing + , npcTestConwayHardForkAtEpoch = EpochNo <$> CC.testConwayHardForkAtEpoch testing + , npcTestConwayHardForkAtVersion = CC.testConwayHardForkAtVersion testing + , npcTestDijkstraHardForkAtEpoch = EpochNo <$> CC.testDijkstraHardForkAtEpoch testing + , npcTestDijkstraHardForkAtVersion = CC.testDijkstraHardForkAtVersion testing + } + + checkpoints = + NodeCheckpointsConfiguration + (CheckpointsFile . (configDir ) . CC.hashed <$> CC.checkpointsFile protocol) + (toHash =<< CC.checkpointsFile protocol) + where + toHash h = CheckpointsHash <$> CC.hash h + +-------------------------------------------------------------------------------- +-- Component conversions +-------------------------------------------------------------------------------- + +-- Field order is (immutable, volatile) for both: cardano-config's +-- @SplitDB ImmutablePath VolatilePath@ and the node's +-- @MultipleDbPaths immutable volatile@ (see Cardano.Node.Run). +fromDbPaths :: CC.NodeDatabasePaths -> NodeDatabasePaths +fromDbPaths = \case + CC.SingleDB fp -> OnePathForAllDbs fp + CC.SplitDB im vol -> MultipleDbPaths im vol + +fromCredentials :: CC.Credentials -> ProtocolFilepaths +fromCredentials creds = + ProtocolFilepaths + { byronCertFile = CCCli.byronDelegationCertificate creds + , byronKeyFile = CCCli.byronSigningKey creds + , shelleyKESSource = fromKESSource <$> CCCli.shelleyKES creds + , shelleyVRFFile = CCCli.shelleyVRFKey creds + , shelleyCertFile = CCCli.shelleyOperationalCertificate creds + , shelleyBulkCredsFile = CCCli.bulkCredentialsFile creds + } + +fromKESSource :: CCCli.KESSource -> KESSource +fromKESSource = \case + CCCli.KESKeyFilePath fp -> KESKeyFilePath fp + CCCli.KESAgentSocketPath s -> KESAgentSocketPath s + +fromShutdownOn :: CCCli.ShutdownOn -> ShutdownOn +fromShutdownOn = \case + CCCli.ShutdownAtSlot w -> ASlot (SlotNo w) + CCCli.ShutdownAtBlock w -> ABlock (BlockNo w) + +fromDiffusionMode :: CCNet.DiffusionMode -> DiffusionMode +fromDiffusionMode = \case + CCNet.InitiatorOnly -> InitiatorOnlyDiffusionMode + CCNet.InitiatorAndResponder -> InitiatorAndResponderDiffusionMode + +fromPeerSharing :: Bool -> PeerSharing +fromPeerSharing True = PeerSharingEnabled +fromPeerSharing False = PeerSharingDisabled + +fromResponderCoreAffinity :: String -> ResponderCoreAffinityPolicy +fromResponderCoreAffinity = \case + "ResponderCoreAffinity" -> ResponderCoreAffinity + _ -> NoResponderCoreAffinity + +-- Spellings match the node's orphan @FromJSON TxSubmissionLogicVersion@ +-- (Ouroboros.Network.OrphanInstances). Falls back to the node default +-- (Last Nothing) on an unrecognised value. +fromTxSubmissionLogicVersion :: String -> Maybe TxSubmissionLogicVersion +fromTxSubmissionLogicVersion = \case + "TxSubmissionLogicV1" -> Just TxSubmissionLogicV1 + "TxSubmissionLogicV2" -> Just TxSubmissionLogicV2 + _ -> Nothing + +-- cardano-config: AcceptedConnectionsLimit . +-- ouroboros: AcceptedConnectionsLimit { hard, soft, delay }. +fromAcceptedConnectionsLimit :: CCNet.AcceptedConnectionsLimit -> AcceptedConnectionsLimit +fromAcceptedConnectionsLimit (CCNet.AcceptedConnectionsLimit hard soft delay) = + AcceptedConnectionsLimit hard soft delay + +fromTracerConnection :: CCCli.TracerConnection -> (Net.HowToConnect, Net.ForwarderMode) +fromTracerConnection (CCCli.TracerConnection tag method) = + (howToConnect, forwarderMode tag) + where + howToConnect = case method of + CCCli.TracerConnectViaPipe fp -> Net.LocalPipe fp + CCCli.TracerConnectViaRemote host pn -> Net.RemoteSocket host (fromIntegral pn) + -- "Accept" => we accept an incoming connection (Responder); + -- "Connect" => we connect out (Initiator). The tag comes from + -- cardano-config's TracerConnection (Cardano.Configuration.CliArgs). + forwarderMode "Connect" = Net.Initiator + forwarderMode _ = Net.Responder + +fromGenesisConfigFlags :: CCCon.GenesisConfigFlags -> Genesis.GenesisConfigFlags +fromGenesisConfigFlags f = + Genesis.GenesisConfigFlags + { Genesis.gcfEnableCSJ = CCCon.gcfEnableCSJ f + , Genesis.gcfEnableLoEAndGDD = CCCon.gcfEnableLoEAndGDD f + , Genesis.gcfEnableLoP = CCCon.gcfEnableLoP f + , Genesis.gcfBlockFetchGracePeriod = CCCon.gcfBlockFetchGracePeriod f + , Genesis.gcfBucketCapacity = CCCon.gcfBucketCapacity f + , Genesis.gcfBucketRate = CCCon.gcfBucketRate f + , Genesis.gcfCSJJumpSize = SlotNo <$> CCCon.gcfCSJJumpSize f + , Genesis.gcfGDDRateLimit = CCCon.gcfGDDRateLimit f + } + +fromByron :: FilePath -> CC.ByronGenesisConfiguration -> NodeByronProtocolConfiguration +fromByron configDir b = + NodeByronProtocolConfiguration + { npcByronGenesisFile = toGenesisFile configDir (CC.byronGenesisFile b) + , npcByronGenesisFileHash = toGenesisHash (CC.byronGenesisFile b) + , npcByronReqNetworkMagic = fromReqNetworkMagic (CC.byronReqNetworkMagic b) + , npcByronPbftSignatureThresh = CC.byronPbftSignatureThresh b + , npcByronSupportedProtocolVersionMajor = CC.byronSupportedProtocolVersionMajor b + , npcByronSupportedProtocolVersionMinor = CC.byronSupportedProtocolVersionMinor b + , npcByronSupportedProtocolVersionAlt = fromMaybe 0 (CC.byronSupportedProtocolVersionAlt b) + } + +-- cardano-config uses its own 'RequiresNetworkMagic' enum (absent => default +-- 'RequiresNoMagic'); the node uses the cardano-crypto enum. +fromReqNetworkMagic :: Maybe CC.RequiresNetworkMagic -> RequiresNetworkMagic +fromReqNetworkMagic = \case + Just CC.RequiresMagic -> RequiresMagic + Just CC.RequiresNoMagic -> RequiresNoMagic + Nothing -> RequiresNoMagic + +-- | Resolve a genesis file path relative to the configuration file's directory. +-- @System.FilePath.()@ leaves absolute paths untouched. +toGenesisFile :: FilePath -> CC.Hashed FilePath -> GenesisFile +toGenesisFile configDir = GenesisFile . (configDir ) . CC.hashed + +toGenesisHash :: CC.Hashed FilePath -> Maybe GenesisHash +toGenesisHash = fmap GenesisHash . CC.hash + +-- TODO(adapter): cardano-config's Mithril snapshot policy and the LSM export +-- path have no representation in the node's LedgerDbConfiguration; the Mithril +-- policy falls back to the default and the export path is dropped. The node also +-- does not consume MinDelay/MaxDelay (sfaDelaySnapshotRange is always UseDefault +-- here, mirroring the legacy parser). An absent backend selector defaults to +-- 'V2InMemory'. +fromLedgerDb :: CC.LedgerDbConfiguration -> LedgerDbConfiguration +fromLedgerDb ldb = + LedgerDbConfiguration + snapshotPolicyArgs + queryBatchSize + selector + noDeprecatedOptions + where + snapshotPolicyArgs = + case CC.snapshots ldb of + Nothing -> defaultSnapshotPolicyArgs + Just CCSto.MithrilSnapshotPolicy -> defaultSnapshotPolicyArgs -- TODO(adapter) + Just (CCSto.CustomSnapshotPolicy opts) -> + SnapshotPolicyArgs + (SnapshotFrequency SnapshotFrequencyArgs + { sfaInterval = maybe UseDefault Override (CCSto.snapshotInterval opts >>= nonZero) + , sfaOffset = maybe UseDefault (Override . SlotNo) (CCSto.slotOffset opts) + , sfaRateLimit = maybe UseDefault (Override . secondsToDiffTime . fromIntegral) (CCSto.snapshotRateLimit opts) + , sfaDelaySnapshotRange = UseDefault + }) + (maybe UseDefault (Override . NumOfDiskSnapshots . fromIntegral) (CCSto.numOfDiskSnapshots opts)) + + queryBatchSize = maybe DefaultQueryBatchSize RequestedQueryBatchSize (CC.queryBatchSize ldb) + + selector = case CC.backendSelector ldb of + Nothing -> V2InMemory + Just CCSto.V2InMemory -> V2InMemory + Just (CCSto.V2LSM dbPath _export) -> V2LSM dbPath diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index 1b648370811..f222bab5f36 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -20,15 +20,12 @@ module Cardano.Node.Configuration.POM , defaultPartialNodeConfiguration , lastOption , makeNodeConfiguration - , parseNodeConfigurationFP , pncProtocol , ncProtocol , getForkPolicy ) where -import Cardano.Crypto (RequiresNetworkMagic (..)) -import Cardano.Ledger.BaseTypes.NonZero (nonZero) import Cardano.Logging.Types import Cardano.Network.ConsensusMode (ConsensusMode (..), defaultConsensusMode) import qualified Cardano.Network.Diffusion.Configuration as Cardano @@ -40,16 +37,12 @@ import Cardano.Node.Protocol.Types (Protocol (..)) import Cardano.Node.Types import Cardano.Rpc.Server.Config (PartialRpcConfig, RpcConfig, RpcConfigF (..), makeRpcConfig) -import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Mempool (MempoolCapacityBytesOverride (..)) import Ouroboros.Consensus.Node (NodeDatabasePaths (..)) import Ouroboros.Consensus.Node.Genesis (GenesisConfig, GenesisConfigFlags, defaultGenesisConfigFlags, mkGenesisConfig) import Ouroboros.Consensus.Storage.LedgerDB.Args (QueryBatchSize (..)) -import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (NumOfDiskSnapshots (..), - SnapshotDelayRange (..), SnapshotFrequency (..), SnapshotFrequencyArgs (..), - SnapshotPolicyArgs (..), defaultSnapshotPolicyArgs, mithrilSnapshotPolicyArgs) -import Ouroboros.Consensus.Util.Args (OverrideOrDefault (..)) +import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (defaultSnapshotPolicyArgs) import Ouroboros.Network.Diffusion.Configuration as Configuration import qualified Ouroboros.Network.Diffusion.Configuration as Ouroboros import qualified Ouroboros.Network.Mux as Mux @@ -59,19 +52,15 @@ import Ouroboros.Network.TxSubmission.Inbound.V2.Types (TxSubmissionIn TxSubmissionLogicVersion (..), defaultTxSubmissionInitDelay) import Control.Concurrent (getNumCapabilities) -import Control.Monad (unless, void, when) +import Control.Monad (unless) import Data.Aeson -import qualified Data.Aeson.Types as Aeson import Data.Hashable (Hashable) import Data.Maybe import Data.Monoid (Last (..)) import Data.Text (Text) -import qualified Data.Text as Text -import Data.Time.Clock (DiffTime, secondsToDiffTime) -import Data.Yaml (decodeFileThrow) +import Data.Time.Clock (DiffTime) import GHC.Generics (Generic) import Options.Applicative -import System.FilePath (takeDirectory, ()) import System.Random (randomIO) import Generic.Data (gmappend) @@ -310,401 +299,9 @@ data PartialNodeConfiguration , pncRpcConfig :: !PartialRpcConfig } deriving (Eq, Generic, Show) -instance AdjustFilePaths PartialNodeConfiguration where - adjustFilePaths f x = - x { pncProtocolConfig = adjustFilePaths f (pncProtocolConfig x) - , pncSocketConfig = adjustFilePaths f (pncSocketConfig x) - } - instance Semigroup PartialNodeConfiguration where (<>) = gmappend -instance FromJSON PartialNodeConfiguration where - parseJSON = - withObject "PartialNodeConfiguration" $ \v -> do - pncStartAsNonProducingNode <- Last <$> v .:? "StartAsNonProducingNode" - - -- Node parameters, not protocol-specific - pncSocketPath <- Last <$> v .:? "SocketPath" - pncDatabaseFile <- Last <$> v .:? "DatabasePath" - pncDiffusionMode - <- Last . fmap getDiffusionMode <$> v .:? "DiffusionMode" - pncExperimentalProtocolsEnabled <- fmap Last $ do - mValue <- v .:? "ExperimentalProtocolsEnabled" - - mOldValue <- v .:? "TestEnableDevelopmentNetworkProtocols" - - when (isJust mOldValue) $ do - when (mOldValue /= mValue) $ - fail "TestEnableDevelopmentNetworkProtocols has been renamed to ExperimentalProtocolsEnabled in the configuration file" - - pure mValue - - -- Blockfetch parameters - pncMaxConcurrencyBulkSync <- Last <$> v .:? "MaxConcurrencyBulkSync" - pncMaxConcurrencyDeadline <- Last <$> v .:? "MaxConcurrencyDeadline" - - -- Protocol parameters - protocol <- v .:? "Protocol" .!= CardanoProtocol - pncProtocolConfig <- - case protocol of - CardanoProtocol -> do - hfp <- parseHardForkProtocol v - fmap (Last . Just) $ - NodeProtocolConfigurationCardano - <$> parseByronProtocol v - <*> parseShelleyProtocol v - <*> parseAlonzoProtocol v - <*> parseConwayProtocol v - <*> (if npcExperimentalHardForksEnabled hfp then Just <$> parseDijkstraProtocol v else pure Nothing) - <*> pure hfp - <*> parseCheckpoints v - pncMaybeMempoolCapacityOverride <- Last <$> parseMempoolCapacityBytesOverride v - - -- LedgerDB configuration - pncLedgerDbConfig <- Last <$> parseLedgerDbConfig v - - -- Network timeouts - pncProtocolIdleTimeout <- Last <$> v .:? "ProtocolIdleTimeout" - pncTimeWaitTimeout <- Last <$> v .:? "TimeWaitTimeout" - pncEgressPollInterval <- Last <$> v .:? "EgressPollInterval" - - - -- AcceptedConnectionsLimit - pncAcceptedConnectionsLimit - <- Last <$> v .:? "AcceptedConnectionsLimit" - - -- P2P Governor parameters, with conservative defaults. - pncDeadlineTargetOfRootPeers <- Last <$> v .:? "TargetNumberOfRootPeers" - pncDeadlineTargetOfKnownPeers <- Last <$> v .:? "TargetNumberOfKnownPeers" - pncDeadlineTargetOfEstablishedPeers <- Last <$> v .:? "TargetNumberOfEstablishedPeers" - pncDeadlineTargetOfActivePeers <- Last <$> v .:? "TargetNumberOfActivePeers" - pncDeadlineTargetOfKnownBigLedgerPeers <- Last <$> v .:? "TargetNumberOfKnownBigLedgerPeers" - pncDeadlineTargetOfEstablishedBigLedgerPeers <- Last <$> v .:? "TargetNumberOfEstablishedBigLedgerPeers" - pncDeadlineTargetOfActiveBigLedgerPeers <- Last <$> v .:? "TargetNumberOfActiveBigLedgerPeers" - pncSyncTargetOfRootPeers <- Last <$> v .:? "SyncTargetNumberOfRootPeers" - pncSyncTargetOfKnownPeers <- Last <$> v .:? "SyncTargetNumberOfKnownPeers" - pncSyncTargetOfEstablishedPeers <- Last <$> v .:? "SyncTargetNumberOfEstablishedPeers" - pncSyncTargetOfActivePeers <- Last <$> v .:? "SyncTargetNumberOfActivePeers" - pncSyncTargetOfKnownBigLedgerPeers <- Last <$> v .:? "SyncTargetNumberOfKnownBigLedgerPeers" - pncSyncTargetOfEstablishedBigLedgerPeers <- Last <$> v .:? "SyncTargetNumberOfEstablishedBigLedgerPeers" - pncSyncTargetOfActiveBigLedgerPeers <- Last <$> v .:? "SyncTargetNumberOfActiveBigLedgerPeers" - -- Minimum number of active big ledger peers we must be connected to - -- in Genesis mode - pncMinBigLedgerPeersForTrustedState <- Last <$> v .:? "MinBigLedgerPeersForTrustedState" - - pncConsensusMode <- Last <$> v .:? "ConsensusMode" - - pncChainSyncIdleTimeout <- Last <$> v .:? "ChainSyncIdleTimeout" - - pncMempoolTimeoutSoft <- Last <$> v .:? "MempoolTimeoutSoft" - pncMempoolTimeoutHard <- Last <$> v .:? "MempoolTimeoutHard" - pncMempoolTimeoutCapacity <- Last <$> v .:? "MempoolTimeoutCapacity" - - -- Peer Sharing - pncPeerSharing <- Last <$> v .:? "PeerSharing" - - -- pncConsensusMode determines whether Genesis is enabled in the first place. - pncGenesisConfigFlags <- Last <$> v .:? "LowLevelGenesisOptions" - - pncResponderCoreAffinityPolicy <- - (\a b -> Last a <> Last b) - <$> v .:? "ResponderCoreAffinityPolicy" - <*> v .:? "ForkPolicy" -- deprecated - - pncRpcConfig <- - RpcConfig - <$> (Last <$> v .:? "EnableRpc") - <*> (Last <$> v .:? "RpcSocketPath") - <*> pure mempty - - txSubmissionLogicVersion <- Last <$> v .:? "TxSubmissionLogicVersion" - let parseInitDelay = - maybe (pncTxSubmissionInitDelay defaultPartialNodeConfiguration) (fmap TxSubmissionInitDelay) - <$> v .:? "TxSubmissionInitDelay" - pncTxSubmissionInitDelay <- parseInitDelay - pure PartialNodeConfiguration { - pncProtocolConfig - , pncSocketConfig = Last . Just $ SocketConfig mempty mempty mempty pncSocketPath - , pncDiffusionMode - , pncExperimentalProtocolsEnabled - , pncMaxConcurrencyBulkSync - , pncMaxConcurrencyDeadline - , pncTraceForwardSocket = mempty - , pncConfigFile = mempty - , pncTopologyFile = mempty - , pncDatabaseFile - , pncProtocolFiles = mempty - , pncValidateDB = mempty - , pncShutdownConfig = mempty - , pncStartAsNonProducingNode - , pncMaybeMempoolCapacityOverride - , pncLedgerDbConfig - , pncProtocolIdleTimeout - , pncTimeWaitTimeout - , pncChainSyncIdleTimeout - , pncMempoolTimeoutSoft - , pncMempoolTimeoutHard - , pncMempoolTimeoutCapacity - , pncEgressPollInterval - , pncAcceptedConnectionsLimit - , pncDeadlineTargetOfRootPeers - , pncDeadlineTargetOfKnownPeers - , pncDeadlineTargetOfEstablishedPeers - , pncDeadlineTargetOfActivePeers - , pncDeadlineTargetOfKnownBigLedgerPeers - , pncDeadlineTargetOfEstablishedBigLedgerPeers - , pncDeadlineTargetOfActiveBigLedgerPeers - , pncSyncTargetOfRootPeers - , pncSyncTargetOfKnownPeers - , pncSyncTargetOfEstablishedPeers - , pncSyncTargetOfActivePeers - , pncSyncTargetOfKnownBigLedgerPeers - , pncSyncTargetOfEstablishedBigLedgerPeers - , pncSyncTargetOfActiveBigLedgerPeers - , pncMinBigLedgerPeersForTrustedState - , pncConsensusMode - , pncPeerSharing - , pncGenesisConfigFlags - , pncResponderCoreAffinityPolicy - , pncRpcConfig - , pncTxSubmissionLogicVersion = txSubmissionLogicVersion - , pncTxSubmissionInitDelay - } - where - parseMempoolCapacityBytesOverride v = parseNoOverride <|> parseOverride - where - parseNoOverride = fmap (MempoolCapacityBytesOverride . ByteSize32) <$> v .:? "MempoolCapacityBytesOverride" - parseOverride = do - maybeString :: Maybe String <- v .:? "MempoolCapacityBytesOverride" - case maybeString of - Just "NoOverride" -> return (Just NoMempoolCapacityBytesOverride) - Just invalid -> fmap Just . Aeson.parseFail $ mconcat - [ "Invalid value for 'MempoolCapacityBytesOverride'. " - , "Expecting byte count or NoOverride. Value was: " - , show invalid - ] - Nothing -> return Nothing - - parseLedgerDbConfig v = do - let snapInterval x = do - si <- x .:? "SnapshotInterval" - when (any (<= 0) si) $ fail $ "Non-positive SnapshotInterval: " <> show si - pure $ Override <$> (si >>= nonZero) - snapNum x = fmap (Override . NumOfDiskSnapshots) <$> x .:? "NumOfDiskSnapshots" - - mTopLevelSnapInterval <- snapInterval v - mTopLevelSnapNum <- snapNum v - - let topLevelOptionsSet = - zip [ void mTopLevelSnapInterval - , void mTopLevelSnapNum] - ["SnapshotInterval", "NumOfDiskSnapshots"] - deprecatedOpts = DeprecatedOptions [ y | (x, y) <- topLevelOptionsSet, isJust x ] - - mLedgerDB <- v .:? "LedgerDB" - case mLedgerDB of - Nothing -> do - let si = fromMaybe UseDefault mTopLevelSnapInterval - sn = fromMaybe UseDefault mTopLevelSnapNum - sf = SnapshotFrequencyArgs { - sfaInterval = si - , sfaOffset = UseDefault - , sfaRateLimit = UseDefault - , sfaDelaySnapshotRange = UseDefault - } - spArgs = SnapshotPolicyArgs (SnapshotFrequency sf) sn - return $ Just $ LedgerDbConfiguration spArgs DefaultQueryBatchSize V2InMemory deprecatedOpts - - Just ledgerDB -> flip (withObject "LedgerDB") ledgerDB $ \o -> do - -- Parse snapshot options from an object, honouring any top-level - -- (deprecated) SnapshotInterval / NumOfDiskSnapshots overrides. - let parseSnapshotOpts s = do - sInterval <- (getLast . (Last mTopLevelSnapInterval <>) . Last <$> snapInterval s) .!= UseDefault - sNum <- (getLast . (Last mTopLevelSnapNum <>) . Last <$> snapNum s) .!= UseDefault - sOffset <- (fmap Override <$> s .:? "SlotOffset") .!= UseDefault - sRateLimit <- (fmap (Override . secondsToDiffTime) <$> s .:? "RateLimit") .!= UseDefault - sMinDelay <- s .:? "MinDelay" - sMaxDelay <- s .:? "MaxDelay" - sDelayRange <- - case (sMinDelay, sMaxDelay) of - (Just minDelay, Just maxDelay) -> - if minDelay <= maxDelay then - pure (Override (SnapshotDelayRange (secondsToDiffTime minDelay) (secondsToDiffTime maxDelay))) - else fail $ "Invalid ledger snapshot delay range, MinDelay > MaxDelay: " - <> show minDelay <> " > " <> show maxDelay - _ -> pure UseDefault - let sf = SnapshotFrequencyArgs { - sfaInterval = sInterval - , sfaOffset = sOffset - , sfaRateLimit = sRateLimit - , sfaDelaySnapshotRange = sDelayRange - } - pure $ SnapshotPolicyArgs (SnapshotFrequency sf) sNum - - qsize <- (fmap RequestedQueryBatchSize <$> o .:? "QueryBatchSize") .!= DefaultQueryBatchSize - backend <- o .:? "Backend" .!= "V2InMemory" - selector <- case backend of - "V2InMemory" -> return V2InMemory - "V2LSM" -> do - lsmPath :: Maybe FilePath <- o .:? "LSMDatabasePath" - pure $ V2LSM lsmPath - _ -> fail $ "Malformed LedgerDB Backend: " <> backend - - -- A named policy (e.g. `Snapshots: Mithril`) selects a whole predefined - -- set of args; an object is parsed field-by-field; absence falls back to - -- the legacy top-level options for backward compatibility. - mSnapshotsVal <- o .:? "Snapshots" - spArgs <- case mSnapshotsVal of - Just (String name) -> case name of - "Mithril" -> pure mithrilSnapshotPolicyArgs - _ -> fail $ "Unknown named ledger snapshot policy: " <> Text.unpack name - <> ". Expected \"Mithril\" or an object with snapshot options." - Just sv -> withObject "Snapshots" parseSnapshotOpts sv - Nothing -> parseSnapshotOpts o - - pure $ Just $ LedgerDbConfiguration spArgs qsize selector deprecatedOpts - - parseByronProtocol v = do - primary <- v .:? "ByronGenesisFile" - secondary <- v .:? "GenesisFile" - npcByronGenesisFile <- - case (primary, secondary) of - (Just g, Nothing) -> return g - (Nothing, Just g) -> return g - (Nothing, Nothing) -> fail $ "Missing required field, either " - ++ "ByronGenesisFile or GenesisFile" - (Just _, Just _) -> fail $ "Specify either ByronGenesisFile" - ++ "or GenesisFile, but not both" - npcByronGenesisFileHash <- v .:? "ByronGenesisHash" - - npcByronReqNetworkMagic <- v .:? "RequiresNetworkMagic" - .!= RequiresNoMagic - npcByronPbftSignatureThresh <- v .:? "PBftSignatureThreshold" - protVerMajor <- v .: "LastKnownBlockVersion-Major" - protVerMinor <- v .: "LastKnownBlockVersion-Minor" - protVerAlt <- v .: "LastKnownBlockVersion-Alt" .!= 0 - - pure NodeByronProtocolConfiguration { - npcByronGenesisFile - , npcByronGenesisFileHash - , npcByronReqNetworkMagic - , npcByronPbftSignatureThresh - , npcByronSupportedProtocolVersionMajor = protVerMajor - , npcByronSupportedProtocolVersionMinor = protVerMinor - , npcByronSupportedProtocolVersionAlt = protVerAlt - } - - parseShelleyProtocol v = do - primary <- v .:? "ShelleyGenesisFile" - secondary <- v .:? "GenesisFile" - npcShelleyGenesisFile <- - case (primary, secondary) of - (Just g, Nothing) -> return g - (Nothing, Just g) -> return g - (Nothing, Nothing) -> fail $ "Missing required field, either " - ++ "ShelleyGenesisFile or GenesisFile" - (Just _, Just _) -> fail $ "Specify either ShelleyGenesisFile" - ++ "or GenesisFile, but not both" - npcShelleyGenesisFileHash <- v .:? "ShelleyGenesisHash" - - pure NodeShelleyProtocolConfiguration { - npcShelleyGenesisFile - , npcShelleyGenesisFileHash - } - - parseAlonzoProtocol v = do - npcAlonzoGenesisFile <- v .: "AlonzoGenesisFile" - npcAlonzoGenesisFileHash <- v .:? "AlonzoGenesisHash" - pure NodeAlonzoProtocolConfiguration { - npcAlonzoGenesisFile - , npcAlonzoGenesisFileHash - } - - parseConwayProtocol v = do - npcConwayGenesisFile <- v .: "ConwayGenesisFile" - npcConwayGenesisFileHash <- v .:? "ConwayGenesisHash" - pure NodeConwayProtocolConfiguration { - npcConwayGenesisFile - , npcConwayGenesisFileHash - } - - parseDijkstraProtocol v = do - npcDijkstraGenesisFile <- v .: "DijkstraGenesisFile" - npcDijkstraGenesisFileHash <- v .:? "DijkstraGenesisHash" - pure NodeDijkstraProtocolConfiguration { - npcDijkstraGenesisFile - , npcDijkstraGenesisFileHash - } - - parseHardForkProtocol v = do - - npcExperimentalHardForksEnabled <- do - mValue <- v .:? "ExperimentalHardForksEnabled" - - mOldValue <- v .:? "TestEnableDevelopmentHardForkEras" - - when (isJust mOldValue) $ do - when (mOldValue /= mValue) $ - fail "TestEnableDevelopmentHardForkEras has been renamed to ExperimentalHardForksEnabled in the configuration file" - - pure (fromMaybe False mValue) - - npcTestShelleyHardForkAtEpoch <- v .:? "TestShelleyHardForkAtEpoch" - npcTestShelleyHardForkAtVersion <- v .:? "TestShelleyHardForkAtVersion" - - npcTestAllegraHardForkAtEpoch <- v .:? "TestAllegraHardForkAtEpoch" - npcTestAllegraHardForkAtVersion <- v .:? "TestAllegraHardForkAtVersion" - - npcTestMaryHardForkAtEpoch <- v .:? "TestMaryHardForkAtEpoch" - npcTestMaryHardForkAtVersion <- v .:? "TestMaryHardForkAtVersion" - - npcTestAlonzoHardForkAtEpoch <- v .:? "TestAlonzoHardForkAtEpoch" - npcTestAlonzoHardForkAtVersion <- v .:? "TestAlonzoHardForkAtVersion" - - npcTestBabbageHardForkAtEpoch <- v .:? "TestBabbageHardForkAtEpoch" - npcTestBabbageHardForkAtVersion <- v .:? "TestBabbageHardForkAtVersion" - - npcTestConwayHardForkAtEpoch <- v .:? "TestConwayHardForkAtEpoch" - npcTestConwayHardForkAtVersion <- v .:? "TestConwayHardForkAtVersion" - - (npcTestDijkstraHardForkAtEpoch, npcTestDijkstraHardForkAtVersion) <- if npcExperimentalHardForksEnabled - then (,) <$> v .:? "TestDijkstraHardForkAtEpoch" <*> v .:? "TestDijkstraHardForkAtVersion" - else pure (Nothing, Nothing) - - pure NodeHardForkProtocolConfiguration - { npcExperimentalHardForksEnabled - - , npcTestShelleyHardForkAtEpoch - , npcTestShelleyHardForkAtVersion - - , npcTestAllegraHardForkAtEpoch - , npcTestAllegraHardForkAtVersion - - , npcTestMaryHardForkAtEpoch - , npcTestMaryHardForkAtVersion - - , npcTestAlonzoHardForkAtEpoch - , npcTestAlonzoHardForkAtVersion - - , npcTestBabbageHardForkAtEpoch - , npcTestBabbageHardForkAtVersion - - , npcTestConwayHardForkAtEpoch - , npcTestConwayHardForkAtVersion - - , npcTestDijkstraHardForkAtEpoch - , npcTestDijkstraHardForkAtVersion - } - - parseCheckpoints v = do - npcCheckpointsFile <- v .:? "CheckpointsFile" - npcCheckpointsFileHash <- v .:? "CheckpointsFileHash" - pure NodeCheckpointsConfiguration - { npcCheckpointsFile - , npcCheckpointsFileHash - } - -- | Default configuration is mainnet defaultPartialNodeConfiguration :: PartialNodeConfiguration defaultPartialNodeConfiguration = @@ -993,10 +590,3 @@ pncProtocol pnc = case pncProtocolConfig pnc of Last Nothing -> Left "Node protocol configuration not found" Last (Just NodeProtocolConfigurationCardano{}) -> Right CardanoProtocol - -parseNodeConfigurationFP :: Maybe ConfigYamlFilePath -> IO PartialNodeConfiguration -parseNodeConfigurationFP Nothing = parseNodeConfigurationFP . getLast $ pncConfigFile defaultPartialNodeConfiguration -parseNodeConfigurationFP (Just (ConfigYamlFilePath fp)) = do - nc <- decodeFileThrow fp - -- Make all the files be relative to the location of the config file. - pure $ adjustFilePaths (takeDirectory fp ) nc diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs deleted file mode 100644 index 0b42c77dc62..00000000000 --- a/cardano-node/src/Cardano/Node/Parsers.hs +++ /dev/null @@ -1,469 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} - -module Cardano.Node.Parsers - ( nodeCLIParser - , parseConfigFile - , parserHelpHeader - , parserHelpOptions - , renderHelpDoc - , parseHostPort - ) where - -import Cardano.Logging.Types -import qualified Cardano.Logging.Types as Net -import Cardano.Node.Configuration.NodeAddress (File (..), - NodeHostIPv4Address (NodeHostIPv4Address), - NodeHostIPv6Address (NodeHostIPv6Address), PortNumber, SocketPath) -import Cardano.Node.Configuration.POM (PartialNodeConfiguration (..), lastOption) -import Cardano.Node.Configuration.Socket -import Cardano.Node.Handlers.Shutdown -import Cardano.Node.Types -import Cardano.Prelude (ConvertText (..)) -import Cardano.Rpc.Server.Config (PartialRpcConfig, RpcConfigF (..)) -import Ouroboros.Consensus.Ledger.SupportsMempool -import Ouroboros.Consensus.Node - -import Data.Char (isDigit) -import Data.Foldable -import Data.Maybe (fromMaybe) -import Data.Monoid (Last (..)) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Word (Word16, Word32) -import Options.Applicative hiding (str, switch) -import qualified Options.Applicative as Opt -import qualified Options.Applicative.Help as OptI -import qualified Prettyprinter.Internal as PP -import System.Posix.Types (Fd (..)) -import Text.Read (readMaybe) - -nodeCLIParser :: Parser PartialNodeConfiguration -nodeCLIParser = subparser - ( commandGroup "Run the node" - <> metavar "run" - <> command "run" - (info (nodeRunParser <**> helper) - (progDesc "Run the node." )) - ) - -nodeRunParser :: Parser PartialNodeConfiguration -nodeRunParser = do - -- Filepaths - topFp <- lastOption parseTopologyFile - dbFp <- lastOption parseNodeDatabasePaths - validate <- lastOption parseValidateDB - socketFp <- lastOption $ parseSocketPath "socket-path" "Path to a cardano-node socket" - traceForwardSocket <- lastOption parseTracerSocketMode - nodeConfigFp <- lastOption parseConfigFile - - -- Protocol files - byronCertFile <- optional parseByronDelegationCert - byronKeyFile <- optional parseByronSigningKey - shelleyKESSource <- optional parseKesSourceFilePath - shelleyVRFFile <- optional parseVrfKeyFilePath - shelleyCertFile <- optional parseOperationalCertFilePath - shelleyBulkCredsFile <- optional parseBulkCredsFilePath - startAsNonProducingNode <- (\depr new -> Last depr <> Last new) - <$> parseStartAsNonProducingNodeDeprecated - <*> parseStartAsNonProducingNode - - -- Node Address - nIPv4Address <- lastOption parseHostIPv4Addr - nIPv6Address <- lastOption parseHostIPv6Addr - nPortNumber <- lastOption parsePort - - -- Shutdown - shutdownIPC <- lastOption parseShutdownIPC - shutdownOnLimit <- lastOption parseShutdownOn - - -- Hidden options (to be removed eventually) - maybeMempoolCapacityOverride <- lastOption parseMempoolCapacityOverride - - -- gRPC - pncRpcConfig <- parseRpcConfig - - pure $ PartialNodeConfiguration - { pncSocketConfig = - Last . Just $ SocketConfig - nIPv4Address - nIPv6Address - nPortNumber - socketFp - , pncConfigFile = ConfigYamlFilePath <$> nodeConfigFp - , pncTopologyFile = TopologyFile <$> topFp - , pncDatabaseFile = dbFp - , pncDiffusionMode = mempty - , pncExperimentalProtocolsEnabled = mempty - , pncProtocolFiles = Last $ Just ProtocolFilepaths - { byronCertFile - , byronKeyFile - , shelleyKESSource - , shelleyVRFFile - , shelleyCertFile - , shelleyBulkCredsFile - } - , pncValidateDB = validate - , pncShutdownConfig = - Last . Just $ ShutdownConfig (getLast shutdownIPC) (getLast shutdownOnLimit) - , pncStartAsNonProducingNode = startAsNonProducingNode - , pncProtocolConfig = mempty - , pncMaxConcurrencyBulkSync = mempty - , pncMaxConcurrencyDeadline = mempty - , pncTraceForwardSocket = traceForwardSocket - , pncMaybeMempoolCapacityOverride = maybeMempoolCapacityOverride - , pncLedgerDbConfig = mempty - , pncProtocolIdleTimeout = mempty - , pncTimeWaitTimeout = mempty - , pncEgressPollInterval = mempty - , pncChainSyncIdleTimeout = mempty - , pncMempoolTimeoutSoft = mempty - , pncMempoolTimeoutHard = mempty - , pncMempoolTimeoutCapacity = mempty - , pncAcceptedConnectionsLimit = mempty - , pncDeadlineTargetOfRootPeers = mempty - , pncDeadlineTargetOfKnownPeers = mempty - , pncDeadlineTargetOfEstablishedPeers = mempty - , pncDeadlineTargetOfActivePeers = mempty - , pncDeadlineTargetOfKnownBigLedgerPeers = mempty - , pncDeadlineTargetOfEstablishedBigLedgerPeers = mempty - , pncDeadlineTargetOfActiveBigLedgerPeers = mempty - , pncSyncTargetOfRootPeers = mempty - , pncSyncTargetOfKnownPeers = mempty - , pncSyncTargetOfEstablishedPeers = mempty - , pncSyncTargetOfActivePeers = mempty - , pncSyncTargetOfKnownBigLedgerPeers = mempty - , pncSyncTargetOfEstablishedBigLedgerPeers = mempty - , pncSyncTargetOfActiveBigLedgerPeers = mempty - , pncMinBigLedgerPeersForTrustedState = mempty - , pncConsensusMode = mempty - , pncPeerSharing = mempty - , pncGenesisConfigFlags = mempty - , pncResponderCoreAffinityPolicy = mempty - , pncRpcConfig - , pncTxSubmissionLogicVersion = mempty - , pncTxSubmissionInitDelay = mempty - } - -parseSocketPath :: Text -- ^ option name - -> Text -- ^ help text - -> Parser SocketPath -parseSocketPath optionName helpMessage = - fmap File $ strOption $ mconcat - [ long (toS optionName) - , help (toS helpMessage) - , completer (bashCompleter "file") - , metavar "FILEPATH" - ] - - --- leave hostname untouched, non-empty --- 0 <= port <= 65535 -parseNodeAddress :: Opt.ReadM Net.HowToConnect -parseNodeAddress = Opt.eitherReader parseHostPort - -parseHostPort :: String -> Either String Net.HowToConnect -parseHostPort str - | (portRev, ':' : hostRev) <- break (== ':') (reverse str) - = if - | null hostRev -> Left "parseHostPort: Empty host." - | null portRev -> Left "parseHostPort: Empty port." - | all isDigit portRev - , Just port <- readMaybe @Word16 (reverse portRev) -> if - | 0 <= port, port <= 65535 -> Right (Net.RemoteSocket (Text.pack (reverse hostRev)) port) - | otherwise -> Left ("parseHostPort: Numeric port '" ++ show port ++ "' out of range: 0 - 65535)") - | otherwise -> Left "parseHostPort: Non-numeric port." - | otherwise - = Left "parseHostPort: No colon found." - -parseTracerSocketMode :: Parser (Net.HowToConnect, ForwarderMode) -parseTracerSocketMode = - asum - [ fmap (, Responder) $ option parseNodeAddress $ mconcat - [ long "tracer-socket-network-accept" - , help "Accept incoming cardano-tracer connection on HOST:PORT" - , metavar "HOST:PORT" - ] - , fmap (, Initiator) $ option parseNodeAddress $ mconcat - [ long "tracer-socket-network-connect" - , help "Connect to cardano-tracer listening on HOST:PORT" - , metavar "HOST:PORT" - ] - , fmap (\host -> (Net.LocalPipe host, Responder)) $ strOption $ mconcat - [ long "tracer-socket-path-accept" - , help "Accept incoming cardano-tracer connection at local socket" - , completer (bashCompleter "file") - , metavar "FILEPATH" - ] - , fmap (\host -> (Net.LocalPipe host, Initiator)) $ strOption $ mconcat - [ long "tracer-socket-path-connect" - , help "Connect to cardano-tracer listening on a local socket" - , completer (bashCompleter "file") - , metavar "FILEPATH" - ] - ] - -parseHostIPv4Addr :: Parser NodeHostIPv4Address -parseHostIPv4Addr = - Opt.option (eitherReader parseNodeHostIPv4Address) ( - long "host-addr" - <> metavar "IPV4" - <> help "An optional IPv4 address" - ) - -parseHostIPv6Addr :: Parser NodeHostIPv6Address -parseHostIPv6Addr = - Opt.option (eitherReader parseNodeHostIPv6Address) ( - long "host-ipv6-addr" - <> metavar "IPV6" - <> help "An optional IPv6 address" - ) - -parseNodeHostIPv4Address :: String -> Either String NodeHostIPv4Address -parseNodeHostIPv4Address str = - maybe - (Left $ - "Failed to parse IPv4 address: " ++ str ++ - ". If you want to specify an IPv6 address, use --host-ipv6-addr option.") - (Right . NodeHostIPv4Address) - (readMaybe str) - -parseNodeHostIPv6Address :: String -> Either String NodeHostIPv6Address -parseNodeHostIPv6Address str = - maybe - (Left $ - "Failed to parse IPv6 address: " ++ str ++ - ". If you want to specify an IPv4 address, use --host-addr option.") - (Right . NodeHostIPv6Address) - (readMaybe str) - -parsePort :: Parser PortNumber -parsePort = - Opt.option ((fromIntegral :: Int -> PortNumber) <$> auto) ( - long "port" - <> metavar "PORT" - <> help "The port number" - <> value 0 -- Use an ephemeral port - ) - -parseConfigFile :: Parser FilePath -parseConfigFile = - strOption - ( long "config" - <> metavar "NODE-CONFIGURATION" - <> help "Configuration file for the cardano-node" - <> completer (bashCompleter "file") - ) - -parseMempoolCapacityOverride :: Parser MempoolCapacityBytesOverride -parseMempoolCapacityOverride = parseOverride <|> parseNoOverride - where - parseOverride :: Parser MempoolCapacityBytesOverride - parseOverride = - MempoolCapacityBytesOverride . ByteSize32 <$> - Opt.option (auto @Word32) - ( long "mempool-capacity-override" - <> metavar "BYTES" - <> help "[DEPRECATED: Set it in config file with key MempoolCapacityBytesOverride] The number of bytes" - ) - parseNoOverride :: Parser MempoolCapacityBytesOverride - parseNoOverride = - flag' NoMempoolCapacityBytesOverride - ( long "no-mempool-capacity-override" - <> help "[DEPRECATED: Set it in config file] Don't override mempool capacity" - ) - -parseNodeDatabasePaths :: Parser NodeDatabasePaths -parseNodeDatabasePaths = parseDbPath <|> parseMultipleDbPaths - -parseDbPath :: Parser NodeDatabasePaths -parseDbPath = - fmap OnePathForAllDbs $ - strOption $ - mconcat - [ long "database-path" - , metavar "FILEPATH" - , help "Directory where the state is stored." - , completer (bashCompleter "file") - ] - -parseMultipleDbPaths :: Parser NodeDatabasePaths -parseMultipleDbPaths = MultipleDbPaths <$> parseImmutableDbPath <*> parseVolatileDbPath - -parseVolatileDbPath :: Parser FilePath -parseVolatileDbPath = strOption $ - mconcat - [ long "volatile-database-path" - , metavar "FILEPATH" - , help "Directory where the state is stored." - , completer (bashCompleter "file") - ] - -parseImmutableDbPath :: Parser FilePath -parseImmutableDbPath = strOption $ - mconcat - [ long "immutable-database-path" - , metavar "FILEPATH" - , help "Directory where the state is stored." - , completer (bashCompleter "file") - ] - - --- | This parser will always override configuration option, even if the --- `--validate-db` is not present. This is fine for `--validate-db` switch, --- but might not be for something else. See `parseStartAsNonProducingNode` for --- an alternative solution. -parseValidateDB :: Parser Bool -parseValidateDB = - Opt.switch ( - long "validate-db" - <> help "Validate all on-disk database files" - ) - -parseShutdownIPC :: Parser Fd -parseShutdownIPC = - Opt.option (Fd <$> auto) ( - long "shutdown-ipc" - <> metavar "FD" - <> help "Shut down the process when this inherited FD reaches EOF" - <> hidden - ) - -parseTopologyFile :: Parser FilePath -parseTopologyFile = - strOption ( - long "topology" - <> metavar "FILEPATH" - <> help "The path to a file describing the topology." - <> completer (bashCompleter "file") - ) - -parseByronDelegationCert :: Parser FilePath -parseByronDelegationCert = - strOption ( long "byron-delegation-certificate" - <> metavar "FILEPATH" - <> help "Path to the delegation certificate." - <> completer (bashCompleter "file") - ) - <|> - strOption - ( long "delegation-certificate" - <> Opt.internal - ) - -parseByronSigningKey :: Parser FilePath -parseByronSigningKey = - strOption ( long "byron-signing-key" - <> metavar "FILEPATH" - <> help "Path to the Byron signing key." - <> completer (bashCompleter "file") - ) - <|> - strOption ( long "signing-key" - <> Opt.internal - ) - -parseOperationalCertFilePath :: Parser FilePath -parseOperationalCertFilePath = - strOption - ( long "shelley-operational-certificate" - <> metavar "FILEPATH" - <> help "Path to the delegation certificate." - <> completer (bashCompleter "file") - ) - -parseBulkCredsFilePath :: Parser FilePath -parseBulkCredsFilePath = - strOption - ( long "bulk-credentials-file" - <> metavar "FILEPATH" - <> help "Path to the bulk pool credentials file." - <> completer (bashCompleter "file") - ) - -parseKesSourceFilePath :: Parser KESSource -parseKesSourceFilePath = asum - [ KESKeyFilePath <$> - strOption - ( long "shelley-kes-key" - <> metavar "FILEPATH" - <> help "Path to the KES signing key." - <> completer (bashCompleter "file") - ) - , KESAgentSocketPath <$> - strOption - ( long "shelley-kes-agent-socket" - <> metavar "SOCKET_FILEPATH" - <> help "Path to the KES Agent socket" - <> completer (bashCompleter "file") - ) - ] - -parseVrfKeyFilePath :: Parser FilePath -parseVrfKeyFilePath = - strOption - ( long "shelley-vrf-key" - <> metavar "FILEPATH" - <> help "Path to the VRF signing key." - <> completer (bashCompleter "file") - ) - -parseStartAsNonProducingNodeDeprecated :: Parser (Maybe Bool) -parseStartAsNonProducingNodeDeprecated = - flag Nothing (Just True) $ mconcat - [ long "non-producing-node" - , help $ mconcat - [ "DEPRECATED, use --start-as-non-producing-node instead. " - , "This option will be removed in one of the future versions of cardano-node." - ] - , hidden - ] - --- | A parser which returns `Nothing` or `Just True`; the default value is set --- in `defaultPartialNodeConfiguration`. This allows to set this option either --- in the configuration file or as command line flag. -parseStartAsNonProducingNode :: Parser (Maybe Bool) -parseStartAsNonProducingNode = - flag Nothing (Just True) $ mconcat - [ long "start-as-non-producing-node" - , help $ mconcat - [ "Start the node as a non block producing node even if " - , "credentials are specified." - ] - ] - -parseRpcConfig :: Parser PartialRpcConfig -parseRpcConfig = do - isEnabled <- lastOption parseRpcToggle - socketPath <- lastOption parseRpcSocketPath - pure $ RpcConfig isEnabled socketPath mempty - where - parseRpcToggle :: Parser Bool - parseRpcToggle = - Opt.flag' True $ mconcat - [ long "grpc-enable" - , help "[EXPERIMENTAL] Enable node gRPC endpoint." - ] - parseRpcSocketPath :: Parser SocketPath - parseRpcSocketPath = - parseSocketPath - "grpc-socket-path" - "[EXPERIMENTAL] gRPC socket path. Defaults to rpc.sock in the same directory as node socket." - --- | Produce just the brief help header for a given CLI option parser, --- without the options. -parserHelpHeader :: String -> Opt.Parser a -> OptI.Doc -parserHelpHeader = flip (OptI.parserUsage (Opt.prefs mempty)) - --- | Produce just the options help for a given CLI option parser, --- without the header. -parserHelpOptions :: Opt.Parser a -> OptI.Doc -parserHelpOptions = fromMaybe mempty . OptI.unChunk . OptI.fullDesc (Opt.prefs mempty) - --- | Render the help pretty document. -renderHelpDoc :: Int -> OptI.Doc -> String -renderHelpDoc cols = - (`PP.renderShowS` "") . OptI.layoutPretty (OptI.LayoutOptions (OptI.AvailablePerLine cols 1.0)) diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index 479a177b734..146e543102f 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -28,13 +28,15 @@ import Cardano.Api.Error (displayError) import qualified Cardano.Api as Api import System.Random (randomIO) +import qualified Cardano.Configuration as CC +import qualified Cardano.Configuration.CliArgs as CCCli import qualified Cardano.Crypto.Init as Crypto +import Cardano.Node.Configuration.Adapter (nodeConfigurationFromCli) import Cardano.Node.Configuration.LedgerDB import Cardano.Node.Configuration.NodeAddress import Cardano.Node.Configuration.POM (NodeConfiguration (..), - PartialNodeConfiguration (..), TimeoutOverride (..), - defaultPartialNodeConfiguration, makeNodeConfiguration, - parseNodeConfigurationFP, getForkPolicy) + TimeoutOverride (..), + getForkPolicy) import Cardano.Node.Configuration.Socket (LocalSocketOrSocketInfo, SocketOrSocketInfo, SocketOrSocketInfo' (..), gatherConfiguredSockets, getSocketOrSocketInfoAddr) @@ -142,7 +144,6 @@ import Data.IP (toSockAddr) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (catMaybes, fromMaybe, mapMaybe) -import Data.Monoid (Last (..)) import Data.Proxy (Proxy (..)) import qualified Data.Set as Set import Data.SOP.Dict @@ -154,7 +155,6 @@ import Data.Time.Clock (getCurrentTime) import Network.DNS (Resolver) import Network.Socket (Socket) import System.Directory (canonicalizePath, createDirectoryIfMissing, makeAbsolute) -import System.FilePath (takeDirectory, ()) import System.IO (hPutStrLn) #ifdef UNIX import GHC.Weak (deRefWeak) @@ -172,9 +172,9 @@ import GHC.Stack {- HLINT ignore "Use fewer imports" -} runNode - :: PartialNodeConfiguration + :: CC.CliArgs -> IO () -runNode cmdPc = do +runNode cli = do installSigTermHandler Crypto.cryptoInit @@ -182,7 +182,7 @@ runNode cmdPc = do nc@NodeConfiguration { ncProtocolConfig , ncProtocolFiles=ncProtocolFiles@ProtocolFilepaths{shelleyVRFFile=mShelleyVrfFile} - } <- buildNodeConfiguration cmdPc + } <- buildNodeConfiguration cli let earlyTracer = stdoutTracer traceWith earlyTracer $ "Node configuration: " <> show nc @@ -198,21 +198,21 @@ runNode cmdPc = do -- don't need these. (Just ncProtocolFiles) - handleNodeWithTracers cmdPc nc consensusProtocol + handleNodeWithTracers cli nc consensusProtocol runThrowExceptT :: Exception e => ExceptT e IO a -> IO a runThrowExceptT act = runExceptT act >>= either Exception.throwIO pure --- | Read node configuration from a file specified in 'PartialNodeConfiguration' +-- | Build the resolved 'NodeConfiguration' from the CLI arguments, using the +-- @cardano-config@ package to parse the configuration file(s) and combine them +-- with the CLI, then the node's own 'makeNodeConfiguration' to apply defaults +-- and validation. See 'Cardano.Node.Configuration.Adapter'. buildNodeConfiguration :: HasCallStack - => PartialNodeConfiguration -- ^ defaults + => CC.CliArgs -> IO NodeConfiguration -buildNodeConfiguration partialConf = do - configYamlPc <- parseNodeConfigurationFP . getLast $ pncConfigFile partialConf - either - (\err -> error $ "Error in creating the NodeConfiguration: " <> err) - pure - $ makeNodeConfiguration (defaultPartialNodeConfiguration <> configYamlPc <> partialConf) +buildNodeConfiguration cli = + nodeConfigurationFromCli cli >>= + either (\err -> error $ "Error in creating the NodeConfiguration: " <> err) pure -- | Workaround to ensure that the main thread throws an async exception on -- receiving a SIGTERM signal. @@ -233,19 +233,17 @@ installSigTermHandler = do return () handleNodeWithTracers - :: PartialNodeConfiguration + :: CC.CliArgs -> NodeConfiguration -> SomeConsensusProtocol -> IO () -handleNodeWithTracers cmdPc nc p@(SomeConsensusProtocol blockType runP) = do +handleNodeWithTracers cli nc p@(SomeConsensusProtocol blockType runP) = do (ProtocolInfo{pInfoConfig}, mkBlockForging) <- Api.protocolInfo @IO runP let networkMagic :: Api.NetworkMagic = getNetworkMagic $ Consensus.configBlock pInfoConfig -- This IORef contains node kernel structure which holds node kernel. -- Used for ledger queries and peer connection status. nodeKernelData <- mkNodeKernelData - let fp = maybe "No file path found!" - unConfigPath - (getLast (pncConfigFile cmdPc)) + let fp = CCCli.configFilePath cli blockForging <- mkBlockForging nullTracer tracers <- initTraceDispatcher @@ -265,7 +263,7 @@ handleNodeWithTracers cmdPc nc p@(SomeConsensusProtocol blockType runP) = do then DisabledBlockForging else EnabledBlockForging)) - handleSimpleNode blockType runP tracers nc networkMagic + handleSimpleNode blockType runP tracers nc cli networkMagic (\nk -> do setNodeKernel nodeKernelData nk traceWith (nodeStateTracer tracers) NodeKernelOnline) @@ -305,13 +303,16 @@ handleSimpleNode -> Api.ProtocolInfoArgs IO blk -> Tracers RemoteAddress LocalAddress blk IO -> NodeConfiguration + -> CC.CliArgs + -- ^ The original CLI arguments, retained so the SIGHUP handler can re-read and + -- re-resolve the configuration (e.g. to reload the RPC configuration). -> NetworkMagic -> (NodeKernel IO RemoteAddress LocalConnectionId blk -> IO ()) -- ^ Called on the 'NodeKernel' after creating it, but before the network -- layer is initialised. This implies this function must not block, -- otherwise the node won't actually start. -> IO () -handleSimpleNode blockType runP tracers nc networkMagic onKernel = do +handleSimpleNode blockType runP tracers nc cli networkMagic onKernel = do logStartupWarnings logDeprecatedLedgerDBOptions @@ -440,7 +441,7 @@ handleSimpleNode blockType runP tracers nc networkMagic onKernel = do (readTVar ledgerPeerSnapshotPathVar) (readTVar useLedgerVar) (writeTVar ledgerPeerSnapshotVar) - updateRpcConfiguration (startupTracer tracers) (ncConfigFile nc) rpcConfigVar + updateRpcConfiguration (startupTracer tracers) cli rpcConfigVar traceWith (startupTracer tracers) (BlockForgingUpdate NotEffective) ) Nothing @@ -485,7 +486,7 @@ handleSimpleNode blockType runP tracers nc networkMagic onKernel = do rnNodeKernelHook = \registry nodeKernel -> do -- reinstall `SIGHUP` handler installSigHUPHandler (startupTracer tracers) (Consensus.kesAgentTracer $ consensusTracers tracers) - blockType nc networkMagic nodeKernel localRootsVar publicRootsVar useLedgerVar + blockType nc cli networkMagic nodeKernel localRootsVar publicRootsVar useLedgerVar useBootstrapVar ledgerPeerSnapshotPathVar ledgerPeerSnapshotVar rpcConfigVar rnNodeKernelHook nodeArgs registry nodeKernel @@ -576,6 +577,7 @@ installSigHUPHandler :: Tracer IO (StartupTrace blk) -> Tracer IO KESAgentClientTrace -> Api.BlockType blk -> NodeConfiguration + -> CC.CliArgs -> NetworkMagic -> NodeKernel IO RemoteAddress (ConnectionId LocalAddress) blk -> StrictTVar IO [(HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig PeerTrustable))] @@ -587,9 +589,9 @@ installSigHUPHandler :: Tracer IO (StartupTrace blk) -> StrictTVar IO RpcConfig -> IO () #ifndef UNIX -installSigHUPHandler _ _ _ _ _ _ _ _ _ _ _ _ _ = return () +installSigHUPHandler _ _ _ _ _ _ _ _ _ _ _ _ _ _ = return () #else -installSigHUPHandler startupTracer kesAgentTracer blockType nc networkMagic nodeKernel localRootsVar +installSigHUPHandler startupTracer kesAgentTracer blockType nc cli networkMagic nodeKernel localRootsVar publicRootsVar useLedgerVar useBootstrapPeersVar ledgerPeerSnapshotPathVar ledgerPeerSnapshotVar rpcConfigVar = void $ Signals.installHandler @@ -606,7 +608,7 @@ installSigHUPHandler startupTracer kesAgentTracer blockType nc networkMagic node (readTVar ledgerPeerSnapshotPathVar) (readTVar useLedgerVar) (writeTVar ledgerPeerSnapshotVar) - updateRpcConfiguration startupTracer (ncConfigFile nc) rpcConfigVar + updateRpcConfiguration startupTracer cli rpcConfigVar ) Nothing #endif @@ -784,22 +786,26 @@ rpcServerLoop startupTracer rpcTracer rpcConfigVar networkMagic = go atomically . modifyTVar rpcConfigVar $ \config -> config{isEnabled = Identity False} #ifdef UNIX --- | Reload RPC configuration from the configuration file -updateRpcConfiguration :: Tracer IO (StartupTrace blk) -- ^ tracer tracing the configuration reload - -> ConfigYamlFilePath -- ^ node configuration file, to reload configuration from +-- | Reload RPC configuration from the configuration file. +-- +-- We re-read and re-resolve the whole configuration through @cardano-config@ +-- (reusing 'buildNodeConfiguration'), then keep only the resulting RPC +-- configuration. The CLI arguments are re-applied, so a @--grpc-*@ flag given at +-- startup keeps taking precedence over the configuration file on reload. +updateRpcConfiguration :: HasCallStack + => Tracer IO (StartupTrace blk) -- ^ tracer tracing the configuration reload + -> CC.CliArgs -- ^ CLI arguments, to re-read and re-resolve the configuration -> StrictTVar IO RpcConfig -- ^ TVar storing RPC configuration -> IO () -updateRpcConfiguration tracer configFilePath rpcConfigVar = do - result <- fmap (join . first Exception.displayException) +updateRpcConfiguration tracer cli rpcConfigVar = do + result <- fmap (first Exception.displayException) . try @Exception.SomeException - . fmap makeNodeConfiguration - . parseNodeConfigurationFP - $ Just configFilePath + $ ncRpcConfig <$> buildNodeConfiguration cli case result of Left err -> -- reload failure, we don't do anything this time traceWith tracer (RpcConfigUpdateError $ pack err) - Right NodeConfiguration{ncRpcConfig=newConfig} -> + Right newConfig -> join . atomically $ do oldConfig <- readTVar rpcConfigVar if oldConfig /= newConfig diff --git a/cardano-node/test/Test/Cardano/Node/POM.hs b/cardano-node/test/Test/Cardano/Node/POM.hs index ef6d2def806..b829225fb04 100644 --- a/cardano-node/test/Test/Cardano/Node/POM.hs +++ b/cardano-node/test/Test/Cardano/Node/POM.hs @@ -23,15 +23,12 @@ import Cardano.Rpc.Server.Config (makeRpcConfig) import Ouroboros.Consensus.Node (NodeDatabasePaths (..)) import Ouroboros.Consensus.Node.Genesis (disableGenesisConfig) import Ouroboros.Consensus.Storage.LedgerDB.Args -import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (defaultSnapshotPolicyArgs, - mithrilSnapshotPolicyArgs) +import Ouroboros.Consensus.Storage.LedgerDB.Snapshots (defaultSnapshotPolicyArgs) import Ouroboros.Network.Block (SlotNo (..)) import Ouroboros.Network.PeerSelection.PeerSharing (PeerSharing (..)) import Ouroboros.Network.TxSubmission.Inbound.V2.Types -import Data.Aeson (eitherDecode) import Data.Bifunctor (first) -import qualified Data.ByteString.Lazy as LBS import Data.Monoid (Last (..)) import Data.String import Data.Text (Text) @@ -293,56 +290,6 @@ eExpectedConfig = do , ncTxSubmissionInitDelay = defaultTxSubmissionInitDelay } --- | Test that the legacy flat LedgerDB snapshot config format (options directly --- under LedgerDB) parses identically to the new nested Snapshots format. --- --- TODO: this test could be removed once the old format is deprecated. -prop_legacySnapshotFormat_POM :: Property -prop_legacySnapshotFormat_POM = - withTests 1 . Hedgehog.property $ do - let legacyJson = "{ " <> dummyRequiredValues <> ", " - <> "\"LedgerDB\": {" - <> " \"Backend\": \"V2InMemory\"," - <> " \"SnapshotInterval\": 4320," - <> " \"NumOfDiskSnapshots\": 2" - <> "} }" - newJson = "{ " <> dummyRequiredValues <> ", " - <> "\"LedgerDB\": {" - <> " \"Backend\": \"V2InMemory\"," - <> " \"Snapshots\": {" - <> " \"SnapshotInterval\": 4320," - <> " \"NumOfDiskSnapshots\": 2" - <> " }" - <> "} }" - legacyConfig :: PartialNodeConfiguration <- evalEither $ eitherDecode legacyJson - newConfig :: PartialNodeConfiguration <- evalEither $ eitherDecode newJson - pncLedgerDbConfig legacyConfig === pncLedgerDbConfig newConfig - --- | Test that the named \"Mithril\" snapshot policy selects --- 'mithrilSnapshotPolicyArgs' as a whole. -prop_mithrilSnapshotPolicy_POM :: Property -prop_mithrilSnapshotPolicy_POM = - withTests 1 . Hedgehog.property $ do - let json = "{ " <> dummyRequiredValues <> ", " - <> "\"LedgerDB\": {" - <> " \"Backend\": \"V2InMemory\"," - <> " \"Snapshots\": \"Mithril\"" - <> "} }" - config :: PartialNodeConfiguration <- evalEither $ eitherDecode json - getLast (pncLedgerDbConfig config) === - Just (LedgerDbConfiguration mithrilSnapshotPolicyArgs DefaultQueryBatchSize V2InMemory noDeprecatedOptions) - -dummyRequiredValues :: LBS.ByteString -dummyRequiredValues = mconcat - [ "\"ByronGenesisFile\": \"x\"" - , ", \"ShelleyGenesisFile\": \"x\"" - , ", \"AlonzoGenesisFile\": \"x\"" - , ", \"ConwayGenesisFile\": \"x\"" - , ", \"LastKnownBlockVersion-Major\": 0" - , ", \"LastKnownBlockVersion-Minor\": 0" - , ", \"LastKnownBlockVersion-Alt\": 0" - ] - -- ----------------------------------------------------------------------------- tests :: IO Bool diff --git a/cardano-testnet/src/Testnet/Types.hs b/cardano-testnet/src/Testnet/Types.hs index 150087cd361..1a9b84e3237 100644 --- a/cardano-testnet/src/Testnet/Types.hs +++ b/cardano-testnet/src/Testnet/Types.hs @@ -51,6 +51,7 @@ import Cardano.Api.Experimental (Some (..)) import qualified Cardano.Chain.Genesis as G import Cardano.Crypto.ProtocolMagic (RequiresNetworkMagic (..)) +import Cardano.Node.Configuration.Adapter (nodeConfigurationFromFile) import Cardano.Node.Configuration.POM import qualified Cardano.Node.Protocol.Byron as Byron import Cardano.Node.Types @@ -232,9 +233,8 @@ getStartTime tempRootPath TestnetRuntime{configurationFile} = withFrozenCallStac SystemStart . G.gdStartTime . G.configGenesisData <$> decodeGenesisFile byronGenesisFilePath where decodeNodeConfiguration :: File NodeConfig In -> ExceptT String IO NodeProtocolConfiguration - decodeNodeConfiguration (File file) = do - partialNodeCfg <- ExceptT $ A.eitherDecodeFileStrict' file - fmap ncProtocolConfig . liftEither . makeNodeConfiguration $ defaultPartialNodeConfiguration <> partialNodeCfg + decodeNodeConfiguration (File file) = + ncProtocolConfig <$> ExceptT (nodeConfigurationFromFile file) decodeGenesisFile :: FilePath -> ExceptT String IO G.Config decodeGenesisFile fp = withExceptT (docToString . prettyError) $ Byron.readGenesis (GenesisFile fp) Nothing RequiresNoMagic