Propagate POM - Types are building

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 =

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

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 ()

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,33 +278,34 @@ 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
   loggingSwitch <- lastToEither "Missing LoggingSwitch" $ pncLoggingSwitch pnc
   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,11 +314,18 @@ makeNodeConfiguration pnc = do
              , ncShutdownIPC = shutdownIPC
              , ncShutdownOnSlotSynced = shutdownOnSlotSynced
              , ncProtocolConfig = protocolConfig
-             , ncSocketPath = socketPath
+             , ncSocketPath = getLast $ pncSocketPath pnc
              , ncMaxConcurrencyBulkSync = maxConcurrencyBulkSync
              , ncMaxConcurrencyDeadline = maxConcurrencyDeadline
              , ncViewMode = viewMode
              , ncLoggingSwitch = loggingSwitch
              , 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

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