Add Partial Options Monoid module

cardano-node/src/Cardano/Node/Configuration/POM.hs

@@ -0,0 +1,328 @@
+
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+{-# OPTIONS_GHC -Wno-noncanonical-monoid-instances #-}
+
+module Cardano.Node.Configuration.POM
+  ( NodeConfiguration (..)
+  , PartialNodeConfiguration(..)
+  , defaultPartialNodeConfiguration
+  , lastOption
+  , makeNodeConfiguration
+  , parseNodeConfigurationFP
+  , pncProtocol
+  , ncProtocol
+  )
+where
+
+import           Cardano.Prelude
+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
+import           Cardano.Crypto (RequiresNetworkMagic (..))
+import           Cardano.Node.Protocol.Types (Protocol (..))
+import           Cardano.Node.Types
+import           Cardano.Tracing.Config
+import           Ouroboros.Network.Block (MaxSlotNo (..))
+
+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
+
+        -- 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
+
+
+data PartialNodeConfiguration
+  = PartialNodeConfiguration
+      {  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)
+       , pncProtocolFiles   :: !(Last ProtocolFilepaths)
+       , pncValidateDB      :: !(Last Bool)
+       , pncShutdownIPC     :: !(Last (Maybe Fd))
+       , pncShutdownOnSlotSynced :: !(Last MaxSlotNo)
+
+          -- Protocol-specific parameters:
+       , pncProtocolConfig :: !(Last NodeProtocolConfiguration)
+
+         -- Node parameters, not protocol-specific:
+       , pncSocketPath     :: !(Last SocketPath)
+
+         -- BlockFetch configuration
+       , pncMaxConcurrencyBulkSync :: !(Last MaxConcurrencyBulkSync)
+       , pncMaxConcurrencyDeadline :: !(Last MaxConcurrencyDeadline)
+
+         -- Logging parameters:
+       , pncViewMode       :: !(Last ViewMode)
+       , pncLoggingSwitch  :: !(Last Bool)
+       , pncLogMetrics     :: !(Last Bool)
+       , 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 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
+      , 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
+      , pncMaxConcurrencyDeadline = pncMaxConcurrencyDeadline x <> pncMaxConcurrencyDeadline y
+      , pncViewMode = pncViewMode x <> pncViewMode y
+      , pncLoggingSwitch = pncLoggingSwitch x <> pncLoggingSwitch y
+      , pncLogMetrics = pncLogMetrics x <> pncLogMetrics y
+      , pncTraceConfig = pncTraceConfig x <> pncTraceConfig y
+      }
+
+
+instance FromJSON PartialNodeConfiguration where
+  parseJSON =
+    withObject "PartialNodeConfiguration" $ \v -> do
+
+      -- Node parameters, not protocol-specific
+      pncSocketPath' <- Last <$> v .:? "SocketPath"
+
+      -- Blockfetch parameters
+      pncMaxConcurrencyBulkSync' <- Last <$> v .:? "MaxConcurrencyBulkSync"
+      pncMaxConcurrencyDeadline' <- Last <$> v .:? "MaxConcurrencyDeadline"
+
+      -- Logging parameters
+      pncViewMode'      <- Last <$> v .:? "ViewMode"
+      pncLoggingSwitch' <- v .:? "TurnOnLogging" .!= True
+      pncLogMetrics'    <- Last <$> v .:? "TurnOnLogMetrics"
+      pncTraceConfig'   <- if pncLoggingSwitch'
+                           then Last . Just <$> traceConfigParser v
+                           else return . Last $ Just TracingOff
+
+      -- Protocol parameters
+      protocol <-  v .:? "Protocol" .!= ByronProtocol
+      pncProtocolConfig' <-
+        case protocol of
+          ByronProtocol ->
+            Last . Just . NodeProtocolConfigurationByron <$> parseByronProtocol v
+
+          ShelleyProtocol ->
+            Last . Just . NodeProtocolConfigurationShelley <$> parseShelleyProtocol v
+
+          CardanoProtocol ->
+            Last . Just  <$> (NodeProtocolConfigurationCardano <$> parseByronProtocol v
+                                                               <*> parseShelleyProtocol v
+                                                               <*> parseHardForkProtocol v)
+      pure mempty {
+             pncProtocolConfig = pncProtocolConfig'
+           , pncSocketPath = pncSocketPath'
+           , pncMaxConcurrencyBulkSync = pncMaxConcurrencyBulkSync'
+           , pncMaxConcurrencyDeadline = pncMaxConcurrencyDeadline'
+           , pncViewMode = pncViewMode'
+           , pncLoggingSwitch = Last $ Just pncLoggingSwitch'
+           , pncLogMetrics = pncLogMetrics'
+           , pncTraceConfig = pncTraceConfig'
+           }
+    where
+      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"
+        npcByronApplicationName     <- v .:? "ApplicationName"
+                                         .!= Byron.ApplicationName "cardano-sl"
+        npcByronApplicationVersion  <- v .:? "ApplicationVersion" .!= 1
+        protVerMajor                <- v .: "LastKnownBlockVersion-Major"
+        protVerMinor                <- v .: "LastKnownBlockVersion-Minor"
+        protVerAlt                  <- v .: "LastKnownBlockVersion-Alt" .!= 0
+
+        pure NodeByronProtocolConfiguration {
+               npcByronGenesisFile
+             , npcByronGenesisFileHash
+             , npcByronReqNetworkMagic
+             , npcByronPbftSignatureThresh
+             , npcByronApplicationName
+             , npcByronApplicationVersion
+             , 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"
+
+        --TODO: these are silly names, allow better aliases:
+        protVerMajor    <- v .:  "LastKnownBlockVersion-Major"
+        protVerMinor    <- v .:  "LastKnownBlockVersion-Minor"
+        protVerMajroMax <- v .:? "MaxKnownMajorProtocolVersion" .!= 1
+
+        pure NodeShelleyProtocolConfiguration {
+               npcShelleyGenesisFile
+             , npcShelleyGenesisFileHash
+             , npcShelleySupportedProtocolVersionMajor = protVerMajor
+             , npcShelleySupportedProtocolVersionMinor = protVerMinor
+             , npcShelleyMaxSupportedProtocolVersion   = protVerMajroMax
+             }
+
+      parseHardForkProtocol v = do
+        npcTestShelleyHardForkAtEpoch   <- v .:? "TestShelleyHardForkAtEpoch"
+        npcTestShelleyHardForkAtVersion <- v .:? "TestShelleyHardForkAtVersion"
+        npcShelleyHardForkNotBeforeEpoch <- v .:? "ShelleyHardForkNotBeforeEpoch"
+        pure NodeHardForkProtocolConfiguration {
+               npcTestShelleyHardForkAtEpoch,
+               npcTestShelleyHardForkAtVersion,
+               npcShelleyHardForkNotBeforeEpoch
+             }
+
+-- Default configuration is mainnet
+defaultPartialNodeConfiguration :: PartialNodeConfiguration
+defaultPartialNodeConfiguration =
+  mempty
+    { pncConfigFile = Last . Just $ ConfigYamlFilePath "configuration/cardano/mainnet-config.json"
+    , pncDatabaseFile = Last . Just $ DbFile "mainnet/db/"
+    , pncLoggingSwitch = Last $ Just True
+    , pncSocketPath = Last $ Just "mainnet/socket/nodesocket"
+    , pncTopologyFile = Last . Just $ TopologyFile "configuration/cardano/mainnet-topology.json"
+    , pncViewMode = Last $ Just SimpleView
+    }
+
+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 NodeConfiguration
+makeNodeConfiguration pnc = do
+  configFile <- lastToEither "Missing YAML config file" $ pncConfigFile pnc
+  topologyFile <- lastToEither "Missing TopologyFile" $ pncTopologyFile pnc
+  databaseFile <- lastToEither "Missing DatabaseFile" $ pncDatabaseFile 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
+  protocolConfig <- lastToEither "Missing ProtocolConfig" $ pncProtocolConfig 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 $ NodeConfiguration
+             { ncNodeAddr = getLast $ pncNodeAddr pnc
+             , ncConfigFile = configFile
+             , ncTopologyFile = topologyFile
+             , ncDatabaseFile = databaseFile
+             , ncProtocolFiles = protocolFiles
+             , ncValidateDB = validateDB
+             , ncShutdownIPC = shutdownIPC
+             , ncShutdownOnSlotSynced = shutdownOnSlotSynced
+             , ncProtocolConfig = protocolConfig
+             , ncSocketPath = getLast $ pncSocketPath pnc
+             , ncMaxConcurrencyBulkSync = getLast $ pncMaxConcurrencyBulkSync pnc
+             , ncMaxConcurrencyDeadline = getLast $ pncMaxConcurrencyDeadline pnc
+             , ncViewMode = viewMode
+             , ncLoggingSwitch = loggingSwitch
+             , ncLogMetrics = logMetrics
+             , ncTraceConfig = traceConfig
+             }
+
+ncProtocol :: NodeConfiguration -> Protocol
+ncProtocol nc =
+  case ncProtocolConfig nc of
+    NodeProtocolConfigurationByron{}   -> ByronProtocol
+    NodeProtocolConfigurationShelley{} -> ShelleyProtocol
+    NodeProtocolConfigurationCardano{} -> CardanoProtocol
+
+pncProtocol :: PartialNodeConfiguration -> Either Text Protocol
+pncProtocol pnc =
+  case pncProtocolConfig pnc of
+    Last Nothing -> Left "Node protocol configuration not found"
+    Last (Just NodeProtocolConfigurationByron{})   -> Right ByronProtocol
+    Last (Just NodeProtocolConfigurationShelley{}) -> Right ShelleyProtocol
+    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

cardano-node/src/Cardano/Node/Types.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralisedNewtypeDeriving #-}
 {-# LANGUAGE NamedFieldPuns #-}
 
@@ -464,6 +465,24 @@ parseNodeConfigurationFP (ConfigYamlFilePath fp) = do
     -- Make all the files be relative to the location of the config file.
     pure $ adjustFilePaths (takeDirectory fp </>) nc
 
+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
+
 -- | A human readable name for the protocol
 --
 protocolName :: Protocol -> String