New topology file format

Fixes #4559.

Author: coot

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

@@ -1,5 +1,8 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
 
 module Cardano.Node.Configuration.TopologyP2P
   ( TopologyError(..)
@@ -30,11 +33,14 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
 import qualified Data.Text as Text
 
+import "contra-tracer" Control.Tracer (Tracer, traceWith)
+
 import           Cardano.Node.Configuration.POM (NodeConfiguration (..))
 import           Cardano.Slotting.Slot (SlotNo (..))
 
 import           Cardano.Node.Configuration.NodeAddress
 import           Cardano.Node.Types
+import           Cardano.Node.Startup (StartupTrace (..))
 import           Cardano.Node.Configuration.Topology (TopologyError (..))
 
 import           Ouroboros.Network.NodeToNode (PeerAdvertise (..))
@@ -132,48 +138,42 @@ data LocalRootPeersGroup = LocalRootPeersGroup
   , valency    :: Int
   } deriving (Eq, Show)
 
+-- | Does not use the 'FromJSON' instance of 'RootConfig', so that
+-- 'accessPoints', 'advertise' and 'valency' fields are attached to the same
+-- object.
 instance FromJSON LocalRootPeersGroup where
   parseJSON = withObject "LocalRootPeersGroup" $ \o ->
                 LocalRootPeersGroup
-                  <$> o .: "localRoots"
+                  <$> parseJSON (Object o)
                   <*> o .: "valency"
 
 instance ToJSON LocalRootPeersGroup where
   toJSON lrpg =
     object
-      [ "localRoots" .= localRoots lrpg
-      , "valency"    .= valency lrpg
+      [ "accessPoints" .= rootAccessPoints (localRoots lrpg)
+      , "advertise" .= rootAdvertise (localRoots lrpg)
+      , "valency" .= valency lrpg
       ]
 
 newtype LocalRootPeersGroups = LocalRootPeersGroups
   { groups :: [LocalRootPeersGroup]
   } deriving (Eq, Show)
 
 instance FromJSON LocalRootPeersGroups where
-  parseJSON = withObject "LocalRootPeersGroups" $ \o ->
-                LocalRootPeersGroups
-                  <$> o .: "groups"
+  parseJSON = fmap LocalRootPeersGroups . parseJSONList
 
 instance ToJSON LocalRootPeersGroups where
-  toJSON lrpg =
-    object
-      [ "groups" .= groups lrpg
-      ]
+  toJSON = toJSON . groups
 
 newtype PublicRootPeers = PublicRootPeers
   { publicRoots :: RootConfig
   } deriving (Eq, Show)
 
 instance FromJSON PublicRootPeers where
-  parseJSON = withObject "PublicRootPeers" $ \o ->
-                PublicRootPeers
-                  <$> o .: "publicRoots"
+  parseJSON = fmap PublicRootPeers . parseJSON
 
 instance ToJSON PublicRootPeers where
-  toJSON prp =
-    object
-      [ "publicRoots" .= publicRoots prp
-      ]
+  toJSON = toJSON . publicRoots
 
 data NetworkTopology = RealNodeTopology !LocalRootPeersGroups ![PublicRootPeers] !UseLedger
   deriving (Eq, Show)
@@ -192,17 +192,66 @@ instance ToJSON NetworkTopology where
                                              , "useLedgerAfterSlot" .= ul
                                              ]
 
+--
+-- Legacy p2p topology file format
+--
+
+-- | A newtype wrapper which provides legacy 'FromJSON' instances.
+--
+newtype Legacy a = Legacy { getLegacy :: a }
+
+instance FromJSON (Legacy a) => FromJSON (Legacy [a]) where
+  parseJSON = fmap (Legacy . map getLegacy) . parseJSONList
+
+instance FromJSON (Legacy LocalRootPeersGroup) where
+  parseJSON = withObject "LocalRootPeersGroup" $ \o ->
+                fmap Legacy $ LocalRootPeersGroup
+                  <$> o .: "localRoots"
+                  <*> o .: "valency"
+
+instance FromJSON (Legacy LocalRootPeersGroups) where
+  parseJSON = withObject "LocalRootPeersGroups" $ \o ->
+                Legacy . LocalRootPeersGroups . getLegacy
+                  <$> o .: "groups"
+
+instance FromJSON (Legacy PublicRootPeers) where
+  parseJSON = withObject "PublicRootPeers" $ \o ->
+                Legacy . PublicRootPeers
+                  <$> o .: "publicRoots"
+
+instance FromJSON (Legacy NetworkTopology) where
+  parseJSON = fmap Legacy
+            . withObject "NetworkTopology" (\o ->
+                RealNodeTopology <$> fmap getLegacy (o .: "LocalRoots")
+                                 <*> fmap getLegacy (o .: "PublicRoots")
+                                 <*> (o .:? "useLedgerAfterSlot" .!= UseLedger DontUseLedger))
+
 -- | Read the `NetworkTopology` configuration from the specified file.
 --
-readTopologyFile :: NodeConfiguration -> IO (Either Text NetworkTopology)
-readTopologyFile nc = do
+readTopologyFile :: Tracer IO (StartupTrace blk)
+                 -> NodeConfiguration -> IO (Either Text NetworkTopology)
+readTopologyFile tr nc = do
   eBs <- Exception.try $ BS.readFile (unTopology $ ncTopologyFile nc)
 
   case eBs of
     Left e -> return . Left $ handler e
-    Right bs -> return . first handlerJSON . eitherDecode $ LBS.fromStrict bs
+    Right bs ->
+      let bs' = LBS.fromStrict bs in
+      first handlerJSON (eitherDecode bs')
+      `combine`
+      first handlerJSON (eitherDecode bs')
 
  where
+  combine :: Either Text NetworkTopology
+          -> Either Text (Legacy NetworkTopology)
+          -> IO (Either Text NetworkTopology)
+  combine a b = case (a, b) of
+    (Right {}, _)     -> return a
+    (_, Right {})     -> traceWith tr NetworkConfigLegacy
+                      >> return (getLegacy <$> b)
+    (Left _, Left _)  -> -- ignore parsing error of legacy format
+                         return a
+
   handler :: IOException -> Text
   handler e = Text.pack $ "Cardano.Node.Configuration.Topology.readTopologyFile: "
                         ++ displayException e
@@ -214,9 +263,10 @@ readTopologyFile nc = do
                     \make sure that you correctly setup EnableP2P \
                     \configuration flag. " <> Text.pack err
 
-readTopologyFileOrError :: NodeConfiguration -> IO NetworkTopology
-readTopologyFileOrError nc =
-      readTopologyFile nc
+readTopologyFileOrError :: Tracer IO (StartupTrace blk)
+                        -> NodeConfiguration -> IO NetworkTopology
+readTopologyFileOrError tr nc =
+      readTopologyFile tr nc
   >>= either (\err -> panic $ "Cardano.Node.Configuration.TopologyP2P.readTopologyFile: "
                            <> err)
              pure

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

@@ -407,7 +407,7 @@ handleSimpleNode runP p2pMode tracers nc onKernel = do
       EnabledP2PMode -> do
         traceWith (startupTracer tracers)
                   (StartupP2PInfo (ncDiffusionMode nc))
-        nt <- TopologyP2P.readTopologyFileOrError nc
+        nt <- TopologyP2P.readTopologyFileOrError (startupTracer tracers) nc
         let (localRoots, publicRoots) = producerAddresses nt
         traceWith (startupTracer tracers)
                 $ NetworkConfig localRoots
@@ -515,14 +515,15 @@ handleSimpleNode runP p2pMode tracers nc onKernel = do
                      developmentNtcVersions)
 
 #ifdef UNIX
+  -- only used when P2P is enabled
   updateTopologyConfiguration :: StrictTVar IO [(Int, Map RelayAccessPoint PeerAdvertise)]
                               -> StrictTVar IO [RelayAccessPoint]
                               -> StrictTVar IO UseLedgerAfter
                               -> Signals.Handler
   updateTopologyConfiguration localRootsVar publicRootsVar useLedgerVar =
     Signals.Catch $ do
       traceWith (startupTracer tracers) NetworkConfigUpdate
-      result <- try $ readTopologyFileOrError nc
+      result <- try $ TopologyP2P.readTopologyFileOrError (startupTracer tracers) nc
       case result of
         Left (FatalError err) ->
           traceWith (startupTracer tracers)

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

@@ -89,6 +89,10 @@ data StartupTrace blk =
   --
   | NetworkConfigUpdateError Text
 
+  -- | Legacy topology file format is used.
+  --
+  | NetworkConfigLegacy
+
   -- | Log peer-to-peer network configuration, either on startup or when its
   -- updated.
   --

cardano-node/src/Cardano/Node/Tracing/Tracers/Startup.hs

@@ -133,6 +133,7 @@ namesStartupInfo = \case
   NetworkConfigUpdateUnsupported            -> ["NetworkConfigUpdateUnsupported"]
   NetworkConfigUpdateError {}               -> ["NetworkConfigUpdateError"]
   NetworkConfig {}                          -> ["NetworkConfig"]
+  NetworkConfigLegacy {}                    -> ["NetworkConfigLegacy"]
   P2PWarning {}                             -> ["P2PWarning"]
   P2PWarningDevelopementNetworkProtocols {} -> ["P2PWarningDevelopementNetworkProtocols"]
   WarningDevelopmentNetworkProtocols {}     -> ["WarningDevelopmentNetworkProtocols"]
@@ -212,6 +213,10 @@ instance ( Show (BlockNodeToNodeVersion blk)
                , "publicRoots" .= toJSON publicRoots
                , "useLedgerAfter" .= UseLedger useLedgerAfter
                ]
+  forMachine _dtal NetworkConfigLegacy =
+      mconcat [ "kind" .= String "NetworkConfigLegacy"
+              , "message" .= String p2pNetworkConfigLegacyMessage
+              ]
   forMachine _dtal P2PWarning =
       mconcat [ "kind" .= String "P2PWarning"
                , "message" .= String p2pWarningMessage ]
@@ -319,6 +324,7 @@ ppStartupInfoTrace (NetworkConfig localRoots publicRoots useLedgerAfter) =
                             ++ show (unSlotNo slotNo)
       DontUseLedger         -> "Don't use ledger to get root peers."
   ]
+ppStartupInfoTrace NetworkConfigLegacy = p2pNetworkConfigLegacyMessage
 
 ppStartupInfoTrace P2PWarning = p2pWarningMessage
 
@@ -365,6 +371,14 @@ p2pWarningDevelopmentNetworkProtocolsMessage :: Text
 p2pWarningDevelopmentNetworkProtocolsMessage =
     "peer-to-peer requires TestEnableDevelopmentNetworkProtocols to be set to True"
 
+p2pNetworkConfigLegacyMessage :: Text
+p2pNetworkConfigLegacyMessage =
+    pack
+  $ intercalate "\n"
+  [ "You are using legacy p2p topology file format."
+  , "See https://github.com/input-output-hk/cardano-node/issues/4559"
+  , "Note that the legacy p2p format will be removed in `1.37` release."
+  ]
 
 docStartupInfo :: Documented (StartupTrace blk)
 docStartupInfo = Documented [