From c77ce66519cfa82557143e712c3bca92c4e426c1 Mon Sep 17 00:00:00 2001 From: Jordan Millar Date: Mon, 14 Sep 2020 14:36:59 +0100 Subject: [PATCH] Propagate POM - Types are building --- cardano-node/app/cardano-node.hs | 19 +-- cardano-node/chairman/chairman.hs | 4 +- .../src/Cardano/Node/Configuration/Logging.hs | 24 ++-- .../src/Cardano/Node/Configuration/POM.hs | 126 ++++++++++++------ .../src/Cardano/Node/Configuration/Socket.hs | 15 +-- .../Cardano/Node/Configuration/Topology.hs | 7 +- .../src/Cardano/Node/Handlers/Shutdown.hs | 20 +-- cardano-node/src/Cardano/Node/Parsers.hs | 61 ++++----- cardano-node/src/Cardano/Node/Protocol.hs | 14 +- cardano-node/src/Cardano/Node/Run.hs | 78 ++++++----- cardano-node/src/Cardano/Node/TUI/Run.hs | 13 +- cardano-node/src/Cardano/Node/Types.hs | 73 +--------- 12 files changed, 216 insertions(+), 238 deletions(-) diff --git a/cardano-node/app/cardano-node.hs b/cardano-node/app/cardano-node.hs index d50044e5182..e96bcd5e1bc 100644 --- a/cardano-node/app/cardano-node.hs +++ b/cardano-node/app/cardano-node.hs @@ -16,12 +16,11 @@ import Data.Version (showVersion) import Paths_cardano_node (version) import System.Info (arch, compilerName, compilerVersion, os) -import Cardano.Node.Configuration.Logging (createLoggingLayer) +import Cardano.Node.Configuration.POM (PartialNodeConfiguration) import Cardano.Node.Handlers.TopLevel import Cardano.Node.Parsers (nodeCLIParser, parserHelpHeader, parserHelpOptions, renderHelpDoc) import Cardano.Node.Run (runNode) -import Cardano.Node.Types (NodeCLI (..)) main :: IO () main = toplevelExceptionHandler $ do @@ -56,7 +55,7 @@ main = toplevelExceptionHandler $ do <$$> parserHelpOptions nodeCLIParser -data Command = RunCmd NodeCLI +data Command = RunCmd PartialNodeConfiguration | VersionCmd -- Yes! A --version flag or version command. Either guess is right! @@ -91,18 +90,8 @@ runVersionCommand = renderVersion = Text.pack . showVersion -runRunCommand :: NodeCLI -> IO () -runRunCommand npm = do - - eLoggingLayer <- runExceptT $ createLoggingLayer - (Text.pack (showVersion version)) - npm - - loggingLayer <- case eLoggingLayer of - Left err -> putTextLn (show err) >> exitFailure - Right res -> return res - - liftIO $ runNode loggingLayer npm +runRunCommand :: PartialNodeConfiguration -> IO () +runRunCommand pnc = liftIO $ runNode pnc command' :: String -> String -> Parser a -> Mod CommandFields a command' c descr p = diff --git a/cardano-node/chairman/chairman.hs b/cardano-node/chairman/chairman.hs index 3febabf70ed..c10bd199589 100644 --- a/cardano-node/chairman/chairman.hs +++ b/cardano-node/chairman/chairman.hs @@ -37,9 +37,9 @@ main = do , caNetworkMagic } <- execParser opts - nc <- liftIO $ parseNodeConfigurationFP caConfigYaml + --nc <- liftIO $ parseNodeConfigurationFP caConfigYaml - let someNodeClientProtocol = mkNodeClientProtocol $ ncProtocol nc + let someNodeClientProtocol = mkNodeClientProtocol $ ncProtocol (panic $ show caConfigYaml) chairmanTest stdoutTracer diff --git a/cardano-node/src/Cardano/Node/Configuration/Logging.hs b/cardano-node/src/Cardano/Node/Configuration/Logging.hs index ab4ae9e9a8c..4153e37cc06 100644 --- a/cardano-node/src/Cardano/Node/Configuration/Logging.hs +++ b/cardano-node/src/Cardano/Node/Configuration/Logging.hs @@ -64,7 +64,8 @@ import Cardano.BM.Trace (Trace, appendName, traceNamedObject) import qualified Cardano.BM.Trace as Trace import Cardano.Config.Git.Rev (gitRev) -import Cardano.Node.Types +import Cardano.Node.Configuration.POM (NodeConfigurationF (..)) +import Cardano.Node.Types hiding (NodeConfiguration (..)) -------------------------------- -- Layer @@ -124,21 +125,18 @@ loggingCLIConfiguration = maybe emptyConfig readConfig -- | Create logging feature for `cardano-node` createLoggingLayer :: Text - -> NodeCLI + -> NodeConfigurationF -> ExceptT ConfigError IO LoggingLayer -createLoggingLayer ver nodecli@NodeCLI{configFile} = do - - -- TODO: we shouldn't be parsing configuration multiple times! - nodeConfig <- liftIO $ parseNodeConfiguration nodecli +createLoggingLayer ver nodeConfig' = do logConfig <- loggingCLIConfiguration $ - if ncLoggingSwitch nodeConfig + if ncLoggingSwitch nodeConfig' -- Re-interpret node config again, as logging 'Configuration': - then Just $ unConfigPath configFile + then Just . unConfigPath $ ncConfigFile nodeConfig' else Nothing -- adapt logging configuration before setup - liftIO $ adaptLogConfig nodeConfig logConfig + liftIO $ adaptLogConfig nodeConfig' logConfig -- These have to be set before the switchboard is set up. liftIO $ do @@ -148,19 +146,19 @@ createLoggingLayer ver nodecli@NodeCLI{configFile} = do (baseTrace, switchBoard) <- liftIO $ setupTrace_ logConfig "cardano" let loggingEnabled :: Bool - loggingEnabled = ncLoggingSwitch nodeConfig + loggingEnabled = ncLoggingSwitch nodeConfig' trace :: Trace IO Text trace = if loggingEnabled then baseTrace else Trace.nullTracer when loggingEnabled $ liftIO $ - loggingPreInit nodeConfig logConfig switchBoard trace + loggingPreInit nodeConfig' logConfig switchBoard trace pure $ mkLogLayer logConfig switchBoard trace where loggingPreInit - :: NodeConfiguration + :: NodeConfigurationF -> Configuration -> Switchboard Text -> Trace IO Text @@ -190,7 +188,7 @@ createLoggingLayer ver nodecli@NodeCLI{configFile} = do -- Record node metrics, if configured startCapturingMetrics trace - adaptLogConfig :: NodeConfiguration -> Configuration -> IO () + adaptLogConfig :: NodeConfigurationF -> Configuration -> IO () adaptLogConfig nodeConfig = liveViewdisablesStdout (ncViewMode nodeConfig) liveViewdisablesStdout SimpleView _ = pure () diff --git a/cardano-node/src/Cardano/Node/Configuration/POM.hs b/cardano-node/src/Cardano/Node/Configuration/POM.hs index a95bee315ce..3da79cc3395 100644 --- a/cardano-node/src/Cardano/Node/Configuration/POM.hs +++ b/cardano-node/src/Cardano/Node/Configuration/POM.hs @@ -1,12 +1,18 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -Wno-noncanonical-monoid-instances #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- TODO: REMOVE ME module Cardano.Node.Configuration.POM - ( defaultPartialNodeConfiguration + ( NodeConfigurationF (..) + , PartialNodeConfiguration(..) + , defaultPartialNodeConfiguration + , lastOption , makeNodeConfiguration + , parseNodeConfigurationFP ) where @@ -16,8 +22,11 @@ import Prelude (String) import Control.Monad (fail) import Data.Aeson import Data.Semigroup (Semigroup (..)) +import Data.Yaml (decodeFileThrow) import Generic.Data (gmappend) import Generic.Data.Orphans () +import Options.Applicative +import System.FilePath (takeDirectory, ()) import System.Posix.Types (Fd (..)) import qualified Cardano.Chain.Update as Byron @@ -43,45 +52,45 @@ data NodeConfigurationF -- What used to be the NodeConfiguration -- Protocol-specific parameters: - , ncProtocolConfig :: NodeProtocolConfiguration + , ncProtocolConfig :: !NodeProtocolConfiguration -- Node parameters, not protocol-specific: - , ncSocketPath :: Maybe SocketPath + , ncSocketPath :: !(Maybe SocketPath) -- BlockFetch configuration - , ncMaxConcurrencyBulkSync :: Maybe MaxConcurrencyBulkSync - , ncMaxConcurrencyDeadline :: Maybe MaxConcurrencyDeadline + , ncMaxConcurrencyBulkSync :: !(Maybe MaxConcurrencyBulkSync) + , ncMaxConcurrencyDeadline :: !(Maybe MaxConcurrencyDeadline) -- Logging parameters: - , ncViewMode :: ViewMode - , ncLoggingSwitch :: Bool - , ncLogMetrics :: Bool - , ncTraceConfig :: TraceOptions + , ncViewMode :: !ViewMode + , ncLoggingSwitch :: !Bool + , ncLogMetrics :: !Bool + , ncTraceConfig :: !TraceOptions } deriving Show data PartialNodeConfiguration = PartialNodeConfiguration { -- Previously NodeCLI - pncnodeAddr :: !(Last (Maybe NodeAddress)) + pncNodeAddr :: !(Last NodeAddress) -- | Filepath of the configuration yaml file. This file determines -- all the configuration settings required for the cardano node -- (logging, tracing, protocol, slot length etc) - , pncconfigFile :: !(Last ConfigYamlFilePath) - , pnctopologyFile :: !(Last TopologyFile) - , pncdatabaseFile :: !(Last DbFile) + , pncConfigFile :: !(Last ConfigYamlFilePath) + , pncTopologyFile :: !(Last TopologyFile) + , pncDatabaseFile :: !(Last DbFile) -- , pncsocketFile :: !(Last (Maybe SocketPath)) - , pncprotocolFiles :: !(Last ProtocolFilepaths) - , pncvalidateDB :: !(Last Bool) - , pncshutdownIPC :: !(Last (Maybe Fd)) - , pncshutdownOnSlotSynced :: !(Last MaxSlotNo) + , pncProtocolFiles :: !(Last ProtocolFilepaths) + , pncValidateDB :: !(Last Bool) + , pncShutdownIPC :: !(Last (Maybe Fd)) + , pncShutdownOnSlotSynced :: !(Last MaxSlotNo) -- From here onward was the original NodeConfiguration -- Protocol-specific parameters: , pncProtocolConfig :: !(Last NodeProtocolConfiguration) -- Node parameters, not protocol-specific: - , pncSocketPath :: !(Last (Maybe SocketPath)) + , pncSocketPath :: !(Last SocketPath) -- BlockFetch configuration , pncMaxConcurrencyBulkSync :: !(Last (Maybe MaxConcurrencyBulkSync)) @@ -94,21 +103,50 @@ data PartialNodeConfiguration , pncTraceConfig :: !(Last TraceOptions) } deriving (Eq, Generic, Show) +instance AdjustFilePaths PartialNodeConfiguration where + adjustFilePaths f x@PartialNodeConfiguration { + pncProtocolConfig, + pncSocketPath + } = + x { + pncProtocolConfig = adjustFilePaths f pncProtocolConfig, + pncSocketPath = adjustFilePaths f pncSocketPath + } + +instance AdjustFilePaths (Last NodeProtocolConfiguration) where + + adjustFilePaths f (Last (Just (NodeProtocolConfigurationByron pc))) = + Last . Just $ NodeProtocolConfigurationByron (adjustFilePaths f pc) + + adjustFilePaths f (Last (Just (NodeProtocolConfigurationShelley pc))) = + Last . Just $ NodeProtocolConfigurationShelley (adjustFilePaths f pc) + + adjustFilePaths f (Last (Just (NodeProtocolConfigurationCardano pcb pcs pch))) = + Last . Just $ NodeProtocolConfigurationCardano (adjustFilePaths f pcb) + (adjustFilePaths f pcs) + pch + adjustFilePaths _ (Last Nothing) = Last Nothing + +instance AdjustFilePaths (Last SocketPath) where + adjustFilePaths f (Last (Just (SocketPath p))) = Last . Just $ SocketPath (f p) + adjustFilePaths _ (Last Nothing) = Last Nothing + + instance Semigroup PartialNodeConfiguration where (<>) = gmappend instance Monoid PartialNodeConfiguration where mempty = PartialNodeConfiguration mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty mappend x y = PartialNodeConfiguration - { pncnodeAddr = pncnodeAddr x <> pncnodeAddr y - , pncconfigFile = pncconfigFile x <> pncconfigFile y - , pnctopologyFile = pnctopologyFile x <> pnctopologyFile y - , pncdatabaseFile = pncdatabaseFile x <> pncdatabaseFile y - -- , pncsocketFile = pncsocketFile x <> pncsocketFile y - , pncprotocolFiles = pncprotocolFiles x <> pncprotocolFiles y - , pncvalidateDB = pncvalidateDB x <> pncvalidateDB y - , pncshutdownIPC = pncshutdownIPC x <> pncshutdownIPC y - , pncshutdownOnSlotSynced = pncshutdownOnSlotSynced x <> pncshutdownOnSlotSynced y + { pncNodeAddr = pncNodeAddr x <> pncNodeAddr y + , pncConfigFile = pncConfigFile x <> pncConfigFile y + , pncTopologyFile = pncTopologyFile x <> pncTopologyFile y + , pncDatabaseFile = pncDatabaseFile x <> pncDatabaseFile y + -- , pncsocketFile = pncSocketFile x <> pncSocketFile y + , pncProtocolFiles = pncProtocolFiles x <> pncProtocolFiles y + , pncValidateDB = pncValidateDB x <> pncValidateDB y + , pncShutdownIPC = pncShutdownIPC x <> pncShutdownIPC y + , pncShutdownOnSlotSynced = pncShutdownOnSlotSynced x <> pncShutdownOnSlotSynced y , pncProtocolConfig = pncProtocolConfig x <> pncProtocolConfig y , pncSocketPath = pncSocketPath x <> pncSocketPath y , pncMaxConcurrencyBulkSync = pncMaxConcurrencyBulkSync x <> pncMaxConcurrencyBulkSync y @@ -240,25 +278,26 @@ defaultPartialNodeConfiguration = mempty , pncLoggingSwitch = Last $ Just True } +lastOption :: Parser a -> Parser (Last a) +lastOption parser = fmap Last $ optional parser + lastToEither :: String -> Last a -> Either String a lastToEither errMsg (Last x) = maybe (Left errMsg) Right x makeNodeConfiguration :: PartialNodeConfiguration -> Either String NodeConfigurationF makeNodeConfiguration pnc = do - nodeAddr <- lastToEither "Missing Node Address" $ pncnodeAddr pnc - configFile <- lastToEither "Missing ConfigFile" $ pncconfigFile pnc - topologyFile <- lastToEither "Missing TopologyFile" $ pnctopologyFile pnc - databaseFile <- lastToEither "Missing DatabaseFile" $ pncdatabaseFile pnc --- socketFile <- lastToEither "Missing SocketFile" $ pncsocketFile pnc - protocolFiles <- lastToEither "Missing ProtocolFiles" $ pncprotocolFiles pnc - validateDB <- lastToEither "Missing ValidateDB" $ pncvalidateDB pnc - shutdownIPC <- lastToEither "Missing ShutdownIPC" $ pncshutdownIPC pnc - shutdownOnSlotSynced <- lastToEither "Missing ShutdownOnSlotSynced" $ pncshutdownOnSlotSynced pnc - + configFile <- lastToEither "Missing ConfigFile" $ pncConfigFile pnc + topologyFile <- lastToEither "Missing TopologyFile" $ pncTopologyFile pnc + databaseFile <- lastToEither "Missing DatabaseFile" $ pncDatabaseFile pnc +-- socketFile <- lastToEither "Missing SocketFile" $ pncSocketFile pnc + protocolFiles <- lastToEither "Missing ProtocolFiles" $ pncProtocolFiles pnc + validateDB <- lastToEither "Missing ValidateDB" $ pncValidateDB pnc + shutdownIPC <- lastToEither "Missing ShutdownIPC" $ pncShutdownIPC pnc + shutdownOnSlotSynced <- lastToEither "Missing ShutdownOnSlotSynced" $ pncShutdownOnSlotSynced pnc +--pncSocketPath protocolConfig <- lastToEither "Missing ProtocolConfig" $ pncProtocolConfig pnc - socketPath <- lastToEither "Missing SocketPath" $ pncSocketPath pnc maxConcurrencyBulkSync <- lastToEither "Missing MaxConcurrencyBulkSync" $ pncMaxConcurrencyBulkSync pnc maxConcurrencyDeadline <- lastToEither "Missing MaxConcurrencyDeadline" $ pncMaxConcurrencyDeadline pnc viewMode <- lastToEither "Missing ViewMode" $ pncViewMode pnc @@ -266,7 +305,7 @@ makeNodeConfiguration pnc = do logMetrics <- lastToEither "Missing LogMetrics" $ pncLogMetrics pnc traceConfig <- lastToEither "Missing TraceConfig" $ pncTraceConfig pnc return $ NodeConfigurationF - { ncNodeAddr = nodeAddr + { ncNodeAddr = getLast $ pncNodeAddr pnc , ncConfigFile = configFile , ncTopologyFile = topologyFile , ncDatabaseFile = databaseFile @@ -275,7 +314,7 @@ makeNodeConfiguration pnc = do , ncShutdownIPC = shutdownIPC , ncShutdownOnSlotSynced = shutdownOnSlotSynced , ncProtocolConfig = protocolConfig - , ncSocketPath = socketPath + , ncSocketPath = getLast $ pncSocketPath pnc , ncMaxConcurrencyBulkSync = maxConcurrencyBulkSync , ncMaxConcurrencyDeadline = maxConcurrencyDeadline , ncViewMode = viewMode @@ -283,3 +322,10 @@ makeNodeConfiguration pnc = do , ncLogMetrics = logMetrics , ncTraceConfig = traceConfig } + +parseNodeConfigurationFP :: Maybe ConfigYamlFilePath -> IO PartialNodeConfiguration +parseNodeConfigurationFP Nothing = panic "No configuration yaml filepath provided" +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/Configuration/Socket.hs b/cardano-node/src/Cardano/Node/Configuration/Socket.hs index 05512ab3d01..d8ea6a28946 100644 --- a/cardano-node/src/Cardano/Node/Configuration/Socket.hs +++ b/cardano-node/src/Cardano/Node/Configuration/Socket.hs @@ -17,7 +17,8 @@ import Control.Monad.Trans.Except.Extra (handleIOExceptT) import Network.Socket (AddrInfo (..), AddrInfoFlag (..), Socket, SocketType (..), defaultHints, getAddrInfo) -import Cardano.Node.Types +import Cardano.Node.Configuration.POM (NodeConfigurationF (..)) +import Cardano.Node.Types hiding (NodeConfiguration (..)) #if defined(mingw32_HOST_OS) #else @@ -90,19 +91,18 @@ renderSocketConfigError (GetAddrInfoError addr ex) = -- * node cli -- * systemd socket activation -- -gatherConfiguredSockets :: NodeConfiguration - -> NodeCLI +gatherConfiguredSockets :: NodeConfigurationF -> ExceptT SocketConfigError IO (SocketOrSocketInfo [Socket] [AddrInfo], SocketOrSocketInfo Socket SocketPath) -gatherConfiguredSockets config cli = do +gatherConfiguredSockets config = do mbAllSocketsFromSystemD <- liftIO getSystemdSockets -- Select the sockets or address for public node-to-node comms -- let mbPublicSocketsAddrFromConfigOrCLI :: Maybe NodeAddress - mbPublicSocketsAddrFromConfigOrCLI = nodeAddr cli + mbPublicSocketsAddrFromConfigOrCLI = ncNodeAddr config --TODO: add config file support mbPublicSocketsFromSystemD = snd <$> mbAllSocketsFromSystemD @@ -117,11 +117,10 @@ gatherConfiguredSockets config cli = do -- Select the socket or path for local node-to-client comms -- - let mbLocalSocketFileConfigOrCLI = socketFile cli `mplus` - ncSocketPath config + let mbLocalSocketFileConfig = ncSocketPath config mbLocalSocketFromSystemD = fst <$> mbAllSocketsFromSystemD - local <- case (mbLocalSocketFileConfigOrCLI, + local <- case (mbLocalSocketFileConfig, mbLocalSocketFromSystemD) of (Nothing, Just sock) -> return (ActualSocket sock) (Just path, Nothing) -> do removeStaleLocalSocket path diff --git a/cardano-node/src/Cardano/Node/Configuration/Topology.hs b/cardano-node/src/Cardano/Node/Configuration/Topology.hs index 168a7ce6907..d4325119839 100644 --- a/cardano-node/src/Cardano/Node/Configuration/Topology.hs +++ b/cardano-node/src/Cardano/Node/Configuration/Topology.hs @@ -25,6 +25,7 @@ import qualified Data.Text as Text import Network.Socket (PortNumber, SockAddr (..)) import Text.Read (readMaybe) +import Cardano.Node.Configuration.POM (NodeConfigurationF (..)) import Cardano.Node.Types import Ouroboros.Consensus.Util.Condense (Condense (..)) @@ -128,9 +129,9 @@ instance ToJSON NetworkTopology where -- | Read the `NetworkTopology` configuration from the specified file. -- While running a real protocol, this gives your node its own address and -- other remote peers it will attempt to connect to. -readTopologyFile :: NodeCLI -> IO (Either Text NetworkTopology) -readTopologyFile ncli = do - eBs <- Exception.try $ BS.readFile (unTopology $ topologyFile ncli) +readTopologyFile :: NodeConfigurationF -> IO (Either Text NetworkTopology) +readTopologyFile nc = do + eBs <- Exception.try $ BS.readFile (unTopology $ ncTopologyFile nc) case eBs of Left e -> return . Left $ handler e diff --git a/cardano-node/src/Cardano/Node/Handlers/Shutdown.hs b/cardano-node/src/Cardano/Node/Handlers/Shutdown.hs index b41a9ecfe21..0b6e7dfb72d 100644 --- a/cardano-node/src/Cardano/Node/Handlers/Shutdown.hs +++ b/cardano-node/src/Cardano/Node/Handlers/Shutdown.hs @@ -39,7 +39,7 @@ import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import Ouroboros.Consensus.Util.STM (onEachChange) import Ouroboros.Network.Block (MaxSlotNo (..), SlotNo, pointSlot) -import Cardano.Node.Types +import Cardano.Node.Configuration.POM (NodeConfigurationF (..)) -- | 'ShutdownFDs' mediate the graceful shutdown requests, -- either external or internal to the process. @@ -131,18 +131,18 @@ triggerShutdown (ShutdownDoorbell (Fd shutFd)) trace reason = do -- external or internal, as requested by configuration in 'NodeCLI', -- while allocating corresponding 'ShutdownFDs', and providing them to the 'action'. withShutdownHandling - :: NodeCLI + :: NodeConfigurationF -> Trace IO Text -> (ShutdownFDs -> IO ()) -> IO () -withShutdownHandling cli trace action = do - sfds <- decideShutdownFds cli +withShutdownHandling nc trace action = do + sfds <- decideShutdownFds nc withShutdownHandler (sfdsListener sfds) trace (action sfds) where - decideShutdownFds :: NodeCLI -> IO ShutdownFDs - decideShutdownFds NodeCLI{shutdownIPC = Just fd} = + decideShutdownFds :: NodeConfigurationF -> IO ShutdownFDs + decideShutdownFds NodeConfigurationF{ncShutdownIPC = Just fd} = pure $ ExternalShutdown (ShutdownListener fd) - decideShutdownFds NodeCLI{shutdownOnSlotSynced = MaxSlotNo{}} = + decideShutdownFds NodeConfigurationF{ncShutdownOnSlotSynced = MaxSlotNo{}} = mkInternalShutdown decideShutdownFds _ = pure NoShutdownFDs @@ -155,14 +155,14 @@ withShutdownHandling cli trace action = do -- spawn a thread that would cause node to shutdown upon ChainDB reaching the -- configuration-defined slot. maybeSpawnOnSlotSyncedShutdownHandler - :: NodeCLI + :: NodeConfigurationF -> ShutdownFDs -> Trace IO Text -> ResourceRegistry IO -> ChainDB.ChainDB IO blk -> IO () -maybeSpawnOnSlotSyncedShutdownHandler cli sfds trace registry chaindb = - case (shutdownOnSlotSynced cli, sfds) of +maybeSpawnOnSlotSyncedShutdownHandler nc sfds trace registry chaindb = + case (ncShutdownOnSlotSynced nc, sfds) of (MaxSlotNo maxSlot, InternalShutdown _sl sd) -> do traceWith (trTransformer MaximalVerbosity $ severityNotice trace) ("will terminate upon reaching " <> pack (show maxSlot)) diff --git a/cardano-node/src/Cardano/Node/Parsers.hs b/cardano-node/src/Cardano/Node/Parsers.hs index b3a514d8713..ec9a375b0f9 100644 --- a/cardano-node/src/Cardano/Node/Parsers.hs +++ b/cardano-node/src/Cardano/Node/Parsers.hs @@ -20,9 +20,10 @@ import System.Posix.Types (Fd (..)) import Ouroboros.Network.Block (MaxSlotNo (..), SlotNo (..)) +import Cardano.Node.Configuration.POM (PartialNodeConfiguration (..), lastOption) import Cardano.Node.Types -nodeCLIParser :: Parser NodeCLI +nodeCLIParser :: Parser PartialNodeConfiguration nodeCLIParser = subparser ( commandGroup "Run the node" <> metavar "run" @@ -31,12 +32,12 @@ nodeCLIParser = subparser (progDesc "Run the node." )) ) -nodeRunParser :: Parser NodeCLI +nodeRunParser :: Parser PartialNodeConfiguration nodeRunParser = do -- Filepaths - topFp <- parseTopologyFile - dbFp <- parseDbPath - socketFp <- optional $ parseSocketPath "Path to a cardano-node socket" + topFp <- lastOption parseTopologyFile + dbFp <- lastOption parseDbPath + socketFp <- lastOption $ parseSocketPath "Path to a cardano-node socket" -- Protocol files byronCertFile <- optional parseDelegationCert @@ -46,33 +47,33 @@ nodeRunParser = do shelleyCertFile <- optional parseOperationalCertFilePath -- Node Address - nAddress <- optional parseNodeAddress + nAddress <- lastOption parseNodeAddress -- NodeConfiguration filepath - nodeConfigFp <- parseConfigFile - - validate <- parseValidateDB - shutdownIPC <- parseShutdownIPC - - shutdownOnSlotSynced <- parseShutdownOnSlotSynced - - pure NodeCLI - { nodeAddr = nAddress - , configFile = ConfigYamlFilePath nodeConfigFp - , topologyFile = TopologyFile topFp - , databaseFile = DbFile dbFp - , socketFile = socketFp - , protocolFiles = ProtocolFilepaths - { byronCertFile - , byronKeyFile - , shelleyKESFile - , shelleyVRFFile - , shelleyCertFile - } - , validateDB = validate - , shutdownIPC - , shutdownOnSlotSynced - } + nodeConfigFp <- lastOption parseConfigFile + + validate <- lastOption parseValidateDB + shutdownIPC <- lastOption parseShutdownIPC + + shutdownOnSlotSynced <- lastOption parseShutdownOnSlotSynced + + pure $ mempty + { pncNodeAddr = nAddress + , pncConfigFile = ConfigYamlFilePath <$> nodeConfigFp + , pncTopologyFile = TopologyFile <$> topFp + , pncDatabaseFile = DbFile <$> dbFp + , pncSocketPath = socketFp + , pncProtocolFiles = Last $ Just ProtocolFilepaths + { byronCertFile + , byronKeyFile + , shelleyKESFile + , shelleyVRFFile + , shelleyCertFile + } + , pncValidateDB = validate + , pncShutdownIPC = shutdownIPC + , pncShutdownOnSlotSynced = shutdownOnSlotSynced + } parseSocketPath :: Text -> Parser SocketPath parseSocketPath helpMessage = diff --git a/cardano-node/src/Cardano/Node/Protocol.hs b/cardano-node/src/Cardano/Node/Protocol.hs index 56e4188ce94..75910b96ac9 100644 --- a/cardano-node/src/Cardano/Node/Protocol.hs +++ b/cardano-node/src/Cardano/Node/Protocol.hs @@ -12,7 +12,8 @@ import Cardano.Prelude import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Except.Extra (firstExceptT) -import Cardano.Node.Types +import Cardano.Node.Configuration.POM (NodeConfigurationF (..)) +import Cardano.Node.Types hiding (NodeConfiguration (..)) import Cardano.Node.Protocol.Byron import Cardano.Node.Protocol.Cardano @@ -24,19 +25,18 @@ import Cardano.Node.Protocol.Types (SomeConsensusProtocol (..)) -- mkConsensusProtocol - :: NodeConfiguration - -> Maybe ProtocolFilepaths + :: NodeConfigurationF -> ExceptT ProtocolInstantiationError IO SomeConsensusProtocol -mkConsensusProtocol NodeConfiguration{ncProtocolConfig} files = +mkConsensusProtocol NodeConfigurationF{ncProtocolConfig, ncProtocolFiles} = case ncProtocolConfig of NodeProtocolConfigurationByron config -> firstExceptT ByronProtocolInstantiationError $ - mkSomeConsensusProtocolByron config files + mkSomeConsensusProtocolByron config (Just ncProtocolFiles) NodeProtocolConfigurationShelley config -> firstExceptT ShelleyProtocolInstantiationError $ - mkSomeConsensusProtocolShelley config files + mkSomeConsensusProtocolShelley config (Just ncProtocolFiles) NodeProtocolConfigurationCardano byronConfig shelleyConfig @@ -46,7 +46,7 @@ mkConsensusProtocol NodeConfiguration{ncProtocolConfig} files = byronConfig shelleyConfig hardForkConfig - files + (Just ncProtocolFiles) ------------------------------------------------------------------------------ -- Errors diff --git a/cardano-node/src/Cardano/Node/Run.hs b/cardano-node/src/Cardano/Node/Run.hs index 04bd9190788..6aba99be16e 100644 --- a/cardano-node/src/Cardano/Node/Run.hs +++ b/cardano-node/src/Cardano/Node/Run.hs @@ -25,6 +25,7 @@ import Data.Functor.Contravariant (contramap) import Data.Proxy (Proxy (..)) import Data.Semigroup ((<>)) import Data.Text (Text, breakOn, pack, take, unlines) +import qualified Data.Text as Text import Data.Version (showVersion) import GHC.Clock (getMonotonicTimeNSec) import Network.HostName (getHostName) @@ -46,8 +47,11 @@ import Cardano.BM.Trace import Cardano.Config.Git.Rev (gitRev) import Cardano.Node.Configuration.Logging (LoggingLayer (..), Severity (..), - shutdownLoggingLayer) -import Cardano.Node.Types + createLoggingLayer, shutdownLoggingLayer) +import Cardano.Node.Configuration.POM (NodeConfigurationF (..), + PartialNodeConfiguration (..), defaultPartialNodeConfiguration, + makeNodeConfiguration, parseNodeConfigurationFP) +import Cardano.Node.Types hiding (NodeConfiguration (..)) import Cardano.Tracing.Config (TraceOptions (..), TraceSelection (..)) import Ouroboros.Consensus.Block (BlockProtocol) @@ -88,18 +92,30 @@ import Cardano.Node.TUI.Run {- HLINT ignore "Use fewer imports" -} runNode - :: LoggingLayer - -> NodeCLI + :: PartialNodeConfiguration -> IO () -runNode loggingLayer npm@NodeCLI{protocolFiles} = do +runNode cmd@PartialNodeConfiguration{pncConfigFile} = do + configYamlPc <- parseNodeConfigurationFP $ getLast pncConfigFile + + nc <- case makeNodeConfiguration $ cmd <> configYamlPc <> defaultPartialNodeConfiguration of + Left err -> panic $ Text.pack err + Right nc' -> return nc' + + eLoggingLayer <- runExceptT $ createLoggingLayer + (Text.pack (showVersion version)) + nc + + loggingLayer <- case eLoggingLayer of + Left err -> putTextLn (show err) >> exitFailure + Right res -> return res + !trace <- setupTrace loggingLayer let tracer = contramap pack $ toLogObject trace - nc <- parseNodeConfiguration npm logTracingVerbosity nc tracer - eitherSomeProtocol <- runExceptT $ mkConsensusProtocol nc (Just protocolFiles) + eitherSomeProtocol <- runExceptT $ mkConsensusProtocol nc SomeConsensusProtocol (p :: Consensus.Protocol IO blk (BlockProtocol blk)) <- case eitherSomeProtocol of @@ -123,7 +139,7 @@ runNode loggingLayer npm@NodeCLI{protocolFiles} = do case viewmode of SimpleView -> do peersThread <- Async.async $ handlePeersListSimple trace nodeKernelData - handleSimpleNode p trace tracers npm (setNodeKernel nodeKernelData) + handleSimpleNode p trace tracers nc (setNodeKernel nodeKernelData) Async.uninterruptibleCancel upTimeThread Async.uninterruptibleCancel peersThread @@ -141,11 +157,11 @@ runNode loggingLayer npm@NodeCLI{protocolFiles} = do be :: LiveViewBackend blk Text <- realize c let lvbe = MkBackend { bEffectuate = effectuate be, bUnrealize = unrealize be } llAddBackend loggingLayer lvbe (UserDefinedBK "LiveViewBackend") - liveViewPostSetup be npm nc + liveViewPostSetup be nc captureCounters be trace -- User will see a terminal graphics and will be able to interact with it. - nodeThread <- Async.async $ handleSimpleNode p trace tracers npm + nodeThread <- Async.async $ handleSimpleNode p trace tracers nc (setNodeKernel nodeKernelData) setNodeThread be nodeThread @@ -160,7 +176,7 @@ runNode loggingLayer npm@NodeCLI{protocolFiles} = do #endif shutdownLoggingLayer loggingLayer -logTracingVerbosity :: NodeConfiguration -> Tracer IO String -> IO () +logTracingVerbosity :: NodeConfigurationF -> Tracer IO String -> IO () logTracingVerbosity nc tracer = case ncTraceConfig nc of TracingOff -> return () @@ -235,29 +251,26 @@ handleSimpleNode => Consensus.Protocol IO blk (BlockProtocol blk) -> Trace IO Text -> Tracers RemoteConnectionId LocalConnectionId blk - -> NodeCLI + -> NodeConfigurationF -> (NodeKernel IO RemoteConnectionId 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 p trace nodeTracers npm onKernel = do +handleSimpleNode p trace nodeTracers nc onKernel = do let pInfo@ProtocolInfo{ pInfoConfig = cfg } = Consensus.protocolInfo p tracer = toLogObject trace - -- Node configuration - nc <- parseNodeConfiguration npm - - createTracers npm nc trace tracer cfg + createTracers nc trace tracer cfg (publicSocketsOrAddrs, localSocketOrPath) <- either throwIO return =<< - runExceptT (gatherConfiguredSockets nc npm) + runExceptT (gatherConfiguredSockets nc) - dbPath <- canonDbPath npm + dbPath <- canonDbPath nc - eitherTopology <- readTopologyFile npm + eitherTopology <- readTopologyFile nc nt <- either (\err -> panic $ "Cardano.Node.Run.handleSimpleNode.readTopologyFile: " <> err) pure eitherTopology @@ -273,7 +286,7 @@ handleSimpleNode p trace nodeTracers npm onKernel = do ipProducers = ipSubscriptionTargets ipProducerAddrs (dnsProducerAddrs, ipProducerAddrs) = producerAddresses nt - withShutdownHandling npm trace $ \sfds -> + withShutdownHandling nc trace $ \sfds -> Node.run RunNodeArgs { rnTraceConsensus = consensusTracers nodeTracers, @@ -285,13 +298,13 @@ handleSimpleNode p trace nodeTracers npm onKernel = do rnNetworkMagic = getNetworkMagic (Consensus.configBlock cfg), rnDatabasePath = dbPath, rnProtocolInfo = pInfo, - rnCustomiseChainDbArgs = customiseChainDbArgs $ validateDB npm, + rnCustomiseChainDbArgs = customiseChainDbArgs $ ncValidateDB nc, rnCustomiseNodeArgs = customiseNodeArgs (ncMaxConcurrencyBulkSync nc) (ncMaxConcurrencyDeadline nc), rnNodeToNodeVersions = supportedNodeToNodeVersions (Proxy @blk), rnNodeToClientVersions = supportedNodeToClientVersions (Proxy @blk), rnNodeKernelHook = \registry nodeKernel -> do - maybeSpawnOnSlotSyncedShutdownHandler npm sfds trace registry + maybeSpawnOnSlotSyncedShutdownHandler nc sfds trace registry (Node.getChainDB nodeKernel) onKernel nodeKernel, rnMaxClockSkew = defaultClockSkew @@ -338,15 +351,14 @@ handleSimpleNode p trace nodeTracers npm onKernel = do } createTracers - :: NodeCLI - -> NodeConfiguration + :: NodeConfigurationF -> Trace IO Text -> Tracer IO Text -> Consensus.TopLevelConfig blk -> IO () - createTracers npm'@NodeCLI{nodeAddr, validateDB} - nc tr tracer cfg = do - eitherTopology <- readTopologyFile npm' + createTracers ncf@NodeConfigurationF{ncNodeAddr, ncValidateDB} + tr tracer cfg = do + eitherTopology <- readTopologyFile ncf nt <- either (\err -> panic $ "Cardano.Node.Run.createTracers.readTopologyFile: " <> err) pure @@ -360,7 +372,7 @@ handleSimpleNode p trace nodeTracers npm onKernel = do traceWith tracer $ unlines [ "" , "**************************************" - , "Host node address: " <> show nodeAddr + , "Host node address: " <> show ncNodeAddr , "My DNS producers are " <> show dnsProducerAddrs , "My IP producers are " <> show ipProducerAddrs , "**************************************" @@ -371,19 +383,19 @@ handleSimpleNode p trace nodeTracers npm onKernel = do nTr = appendName "networkMagic" tr vTr = appendName "version" tr cTr = appendName "commit" tr - traceNamedObject rTr (meta, LogMessage (show (ncProtocol nc))) + traceNamedObject rTr (meta, LogMessage ("THIS SHOULD BE THE PROTOCOL")) --TODO: Fix me traceNamedObject nTr (meta, LogMessage ("NetworkMagic " <> show (unNetworkMagic . getNetworkMagic $ Consensus.configBlock cfg))) traceNamedObject vTr (meta, LogMessage . pack . showVersion $ version) traceNamedObject cTr (meta, LogMessage gitRev) - when validateDB $ traceWith tracer "Performing DB validation" + when ncValidateDB $ traceWith tracer "Performing DB validation" -------------------------------------------------------------------------------- -- Helper functions -------------------------------------------------------------------------------- -canonDbPath :: NodeCLI -> IO FilePath -canonDbPath NodeCLI{databaseFile = DbFile dbFp} = +canonDbPath :: NodeConfigurationF -> IO FilePath +canonDbPath NodeConfigurationF{ncDatabaseFile = DbFile dbFp} = canonicalizePath =<< makeAbsolute dbFp createDiffusionArguments diff --git a/cardano-node/src/Cardano/Node/TUI/Run.hs b/cardano-node/src/Cardano/Node/TUI/Run.hs index f344b002f5e..b9c452cf601 100644 --- a/cardano-node/src/Cardano/Node/TUI/Run.hs +++ b/cardano-node/src/Cardano/Node/TUI/Run.hs @@ -34,23 +34,24 @@ import Cardano.Node.TUI.Drawing (LiveViewState (..), LiveViewThread (. import Cardano.Node.TUI.EventHandler (LiveViewBackend (..)) import Cardano.Tracing.Peer (Peer (..)) -import Cardano.Node.Types +import Cardano.Node.Configuration.POM (NodeConfigurationF (..)) +import Cardano.Node.Types hiding (NodeConfiguration (..)) -- | Change a few fields in the LiveViewState after it has been initialized above. -liveViewPostSetup :: NFData a => LiveViewBackend blk a -> NodeCLI -> NodeConfiguration-> IO () -liveViewPostSetup lvbe ncli nc = do +liveViewPostSetup :: NFData a => LiveViewBackend blk a -> NodeConfigurationF-> IO () +liveViewPostSetup lvbe nc = do modifyMVar_ (getbe lvbe) $ \lvs -> pure lvs { lvsNodeId = nodeId - , lvsProtocol = ncProtocol nc - , lvsRelease = protocolName (ncProtocol nc) + , lvsProtocol = panic "NEED PROTOCOL HERE" --TODO: FIX ME --ncProtocol nc + , lvsRelease = "NEED PROTOCOL NAME HERE" --TODO: FIX ME protocolName (ncProtocol nc) } where --TODO: this is meaningless. Nodes do not have ids. The port number is not -- an ID. We don't even have a port number that we know if we're given our -- listening socket via systemd socket activation. nodeId :: Text - nodeId = Text.pack $ "Port: " <> maybe "-" show (naPort <$> nodeAddr ncli) + nodeId = Text.pack $ "Port: " <> maybe "-" show (naPort <$> ncNodeAddr nc) setNodeThread :: NFData a => LiveViewBackend blk a -> Async.Async () -> IO () setNodeThread lvbe nodeThr = diff --git a/cardano-node/src/Cardano/Node/Types.hs b/cardano-node/src/Cardano/Node/Types.hs index 2408cf1d3d3..a6efdb4517c 100644 --- a/cardano-node/src/Cardano/Node/Types.hs +++ b/cardano-node/src/Cardano/Node/Types.hs @@ -3,11 +3,11 @@ {-# LANGUAGE NamedFieldPuns #-} module Cardano.Node.Types - ( ConfigError(..) + ( AdjustFilePaths(..) + , ConfigError(..) , ConfigYamlFilePath(..) , DbFile(..) , GenesisFile(..) - , NodeCLI(..) , NodeConfiguration(..) , ProtocolFilepaths (..) , GenesisHash(..) @@ -23,8 +23,6 @@ module Cardano.Node.Types , TopologyFile(..) , ViewMode(..) , ncProtocol - , parseNodeConfiguration - , parseNodeConfigurationFP , protocolName ) where @@ -35,10 +33,7 @@ import Control.Monad (fail) import Data.Aeson import Data.IP (IP) import qualified Data.Text as Text -import Data.Yaml (decodeFileThrow) import Network.Socket (PortNumber) -import System.FilePath (takeDirectory, ()) -import System.Posix.Types (Fd) import Cardano.Api.Typed (EpochNo) import qualified Cardano.Chain.Update as Byron @@ -46,7 +41,6 @@ import Cardano.Crypto (RequiresNetworkMagic (..)) import qualified Cardano.Crypto.Hash as Crypto import Cardano.Node.Protocol.Types (Protocol (..)) import Cardano.Tracing.Config (TraceOptions (..), traceConfigParser) -import Ouroboros.Network.Block (MaxSlotNo (..)) --TODO: things will probably be clearer if we don't use these newtype wrappers and instead -- use records with named fields in the CLI code. @@ -144,21 +138,6 @@ instance ToJSON NodeHostAddress where Just ip -> String (Text.pack (show ip)) Nothing -> Null -data NodeCLI = NodeCLI - { nodeAddr :: !(Maybe NodeAddress) - -- | Filepath of the configuration yaml file. This file determines - -- all the configuration settings required for the cardano node - -- (logging, tracing, protocol, slot length etc) - , configFile :: !ConfigYamlFilePath - , topologyFile :: !TopologyFile - , databaseFile :: !DbFile - , socketFile :: !(Maybe SocketPath) - , protocolFiles :: !ProtocolFilepaths - , validateDB :: !Bool - , shutdownIPC :: !(Maybe Fd) - , shutdownOnSlotSynced :: !MaxSlotNo - } - data NodeConfiguration = NodeConfiguration { -- Protocol-specific parameters: @@ -178,45 +157,6 @@ data NodeConfiguration , ncTraceConfig :: TraceOptions } deriving Show - -{- -data NodeCLI = NodeCLI - { - } - -data NodeConfiguration - = NodeConfiguration - { ncNodeAddr :: !(Maybe NodeAddress) - -- | Filepath of the configuration yaml file. This file determines - -- all the configuration settings required for the cardano node - -- (logging, tracing, protocol, slot length etc) - , ncConfigFile :: !ConfigYamlFilePath - , ncTopologyFile :: !TopologyFile - , ncDatabaseFile :: !DbFile - , ncProtocolFiles :: !ProtocolFilepaths - , ncValidateDB :: !Bool - , ncShutdownIPC :: !(Maybe Fd) - , ncShutdownOnSlotSynced :: !MaxSlotNo - - -- What used to be the NodeConfiguration - -- Protocol-specific parameters: - , ncProtocolConfig :: NodeProtocolConfiguration - - -- Node parameters, not protocol-specific: - , ncSocketPath :: Maybe SocketPath - - -- BlockFetch configuration - , ncMaxConcurrencyBulkSync :: Maybe MaxConcurrencyBulkSync - , ncMaxConcurrencyDeadline :: Maybe MaxConcurrencyDeadline - - -- Logging parameters: - , ncViewMode :: ViewMode - , ncLoggingSwitch :: Bool - , ncLogMetrics :: Bool - , ncTraceConfig :: TraceOptions - } deriving Show --} - class AdjustFilePaths a where adjustFilePaths :: (FilePath -> FilePath) -> a -> a @@ -494,15 +434,6 @@ ncProtocol nc = NodeProtocolConfigurationShelley{} -> ShelleyProtocol NodeProtocolConfigurationCardano{} -> CardanoProtocol -parseNodeConfiguration :: NodeCLI -> IO NodeConfiguration -parseNodeConfiguration NodeCLI{configFile} = parseNodeConfigurationFP configFile - -parseNodeConfigurationFP :: ConfigYamlFilePath -> IO NodeConfiguration -parseNodeConfigurationFP (ConfigYamlFilePath fp) = do - nc <- decodeFileThrow fp - -- Make all the files be relative to the location of the config file. - pure $ adjustFilePaths (takeDirectory fp ) nc - -- | A human readable name for the protocol -- protocolName :: Protocol -> String