diff --git a/bench/cardano-topology/app/cardano-topology.hs b/bench/cardano-topology/app/cardano-topology.hs index 5945f4c1e1b..c17574ac6da 100644 --- a/bench/cardano-topology/app/cardano-topology.hs +++ b/bench/cardano-topology/app/cardano-topology.hs @@ -11,7 +11,8 @@ import Prelude hiding (id) import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy.Char8 as LBS +-- Package: bytestring. +import qualified Data.ByteString.Lazy.Char8 as BSL8 import qualified Data.GraphViz as G import qualified Data.GraphViz.Attributes.Complete as G import qualified Data.GraphViz.Printing as G @@ -19,24 +20,48 @@ import qualified Data.Text.Lazy.IO as T import Options.Applicative import qualified Cardano.Benchmarking.Topology as Topo +import qualified Cardano.Benchmarking.Topology.Projection as Projection + +-------------------------------------------------------------------------------- + +data Cli = + Make (Topo.CoreNodesParams, FilePath, Maybe FilePath, Bool) + | ProjectionFor FilePath ProjectionFor + +data ProjectionFor = + BFT Int Int + | Pool Int Int + | Proxy + | ChaindbServer + | Explorer Int Int + deriving Show -------------------------------------------------------------------------------- main :: IO () main = do - (coreNodesParams, topoJson, topoDot, withExplorer) <- execParser cliOpts - let cores = Topo.mkCoreNodes coreNodesParams - relays = [ - Topo.mkExplorer (Topo.AWS Topo.EU_CENTRAL_1) cores - | withExplorer - ] - writeTopo cores relays topoJson - maybe (pure ()) (writeDot cores) topoDot + cli <- getOpts + case cli of + Make (coreNodesParams, topoJson, topoDot, withExplorer) -> do + let cores = Topo.mkCoreNodes coreNodesParams + let relays = [ + Topo.mkExplorer (Topo.AWS Topo.EU_CENTRAL_1) cores + | withExplorer + ] + writeTopo cores relays topoJson + maybe (pure ()) (writeDot cores) topoDot + (ProjectionFor topologyPath projectionFor) -> do + eitherTopology <- Aeson.eitherDecodeFileStrict topologyPath + let topology = case eitherTopology of + (Left errorMsg) -> + error $ "Not a valid topology: " ++ errorMsg + (Right value) -> value + writeProjectionFor topology projectionFor -------------------------------------------------------------------------------- -- | Locations from the CLI are parsed first using the "legacy mode" for --- backward compatiblity, in this mode locations have a default AWS region that +-- backward compatibility, in this mode locations have a default AWS region that -- are the ones cardano-ops is using. The new format is either "loopback" or a -- supported AWS Region. cliLocation :: String -> Either String Topo.Location @@ -49,32 +74,47 @@ cliLocation = \case -- New format. str -> Aeson.eitherDecode -- Make the string JSON valid by enclosing it with quotes. - (LBS.pack $ "\"" ++ str ++ "\"") - - -cliOpts :: ParserInfo (Topo.CoreNodesParams, FilePath, Maybe FilePath, Bool) -cliOpts = info (cliParser <**> helper) - ( fullDesc - <> progDesc "Cardano topology generator" - <> header "make-topology - generate Cardano node topologies" ) - where - cliParser :: Parser (Topo.CoreNodesParams, FilePath, Maybe FilePath, Bool) - cliParser = - (,,,) - <$> subparser coreNodesParamsParser - <*> strOption - ( long "topology-output" - <> help "Topology file to write" - <> metavar "OUTFILE" ) - <*> optional - (strOption - ( long "dot-output" - <> help "Dot file to write" - <> metavar "OUTFILE" )) - <*> flag False True - ( long "with-explorer" - <> help "Add an explorer to the topology") + (BSL8.pack $ "\"" ++ str ++ "\"") + +getOpts :: IO Cli +getOpts = execParser $ info + ( + (hsubparser $ + command "make" + (info + (Make <$> cliParserMake) + ( fullDesc + <> header "make" + <> progDesc "Create a cluster topology" + ) + ) + <> + command "projection-for" + (info + ( ProjectionFor + <$> strOption + ( long "topology-input" + <> help "Topology file" + <> metavar "INPUTFILE" + ) + <*> cliParserProjection + ) + ( fullDesc + <> header "projection-for" + <> progDesc "Create an individual topology" + ) + ) + ) + <**> helper + ) + ( fullDesc + <> progDesc "Cardano topology generation for Performance & Tracing" + <> header "Cardano node topologies tool" + ) +cliParserMake :: Parser (Topo.CoreNodesParams, FilePath, Maybe FilePath, Bool) +cliParserMake = + let coreNodesParamsParser = command "line" (info @@ -141,6 +181,80 @@ cliOpts = info (cliParser <**> helper) then Nothing -- The BFT node has no pools else Just 1 -- Dense pools are denoted by any amount >1 _ -> Just 2 + in + (,,,) + <$> subparser coreNodesParamsParser + <*> strOption + ( long "topology-output" + <> help "Topology file to write" + <> metavar "OUTFILE" + ) + <*> optional + (strOption + ( long "dot-output" + <> help "Dot file to write" + <> metavar "OUTFILE" )) + <*> flag False True + ( long "with-explorer" + <> help "Add an explorer to the topology") + +cliParserProjection :: Parser ProjectionFor +cliParserProjection = + let + parseBasePort = + option auto + ( long "baseport" + <> metavar "BASEPORT" + <> help "Base port" + ) + parseNodeNumber = + option auto + ( long "node-number" + <> short 'i' + <> metavar "NODENUMBER" + <> help "Base port" + ) + in subparser $ + command "bft" + (info + (BFT <$> parseNodeNumber <*> parseBasePort) + ( progDesc "BFT" + <> fullDesc + <> header "Generate the topology file for a BFT node" + ) + ) + <> command "pool" + (info + (pure $ Pool 0 0) + ( progDesc "Pool" + <> fullDesc + <> header "Generate the topology file for a pool node" + ) + ) + <> command "proxy" + (info + (pure Proxy) + ( progDesc "Proxy" + <> fullDesc + <> header "Generate the topology file for a proxy node" + ) + ) + <> command "chaindb-server" + (info + (pure ChaindbServer) + ( progDesc "ChainDB Server" + <> fullDesc + <> header "Generate the topology file for a ChainDB server node" + ) + ) + <> command "explorer" + (info + (pure $ Explorer 0 0) + ( progDesc "Explorer" + <> fullDesc + <> header "Generate the topology file for an explorer node" + ) + ) -------------------------------------------------------------------------------- @@ -195,3 +309,16 @@ locationColor = \case (Topo.AWS Topo.US_EAST_1) -> G.RGB 200 250 200 (Topo.AWS Topo.US_EAST_2) -> G.RGB 200 250 200 Topo.Loopback -> G.RGB 200 200 250 + +-------------------------------------------------------------------------------- + +writeProjectionFor :: Topo.Topology -> ProjectionFor -> IO () +writeProjectionFor topology (BFT i basePort) = writeProjectionBFTPool topology i basePort +writeProjectionFor topology (Pool i basePort) = writeProjectionBFTPool topology i basePort +writeProjectionFor topology Proxy = error $ show topology +writeProjectionFor topology ChaindbServer = error $ show topology +writeProjectionFor topology c@(Explorer _ _) = error $ "ERROR: " ++ show topology ++ " " ++ show c + +writeProjectionBFTPool :: Topo.Topology -> Int -> Int -> IO () +writeProjectionBFTPool topology i basePort = + BSL8.putStrLn $ Aeson.encode $ Projection.projectionP2P topology i basePort diff --git a/bench/cardano-topology/cardano-topology.cabal b/bench/cardano-topology/cardano-topology.cabal index 69aadca71f9..17a696bc201 100644 --- a/bench/cardano-topology/cardano-topology.cabal +++ b/bench/cardano-topology/cardano-topology.cabal @@ -39,11 +39,15 @@ library import: project-config hs-source-dirs: src exposed-modules: Cardano.Benchmarking.Topology + , Cardano.Benchmarking.Topology.Projection , Cardano.Benchmarking.Topology.Types build-depends: base >=4.12 && <5 , aeson , bytestring , text + , network + , iproute + , dns executable cardano-topology import: project-config diff --git a/bench/cardano-topology/src/Cardano/Benchmarking/Topology/Projection.hs b/bench/cardano-topology/src/Cardano/Benchmarking/Topology/Projection.hs new file mode 100644 index 00000000000..e06405b8208 --- /dev/null +++ b/bench/cardano-topology/src/Cardano/Benchmarking/Topology/Projection.hs @@ -0,0 +1,477 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} + +-------------------------------------------------------------------------------- + +module Cardano.Benchmarking.Topology.Projection ( + projection +, projectionP2P +) where + +-------------------------------------------------------------------------------- + +import Prelude +import Control.Applicative ((<|>)) +import Data.Bool (bool) +import Data.Word (Word64) +import GHC.Generics +import Text.Read (readMaybe) +-- Package: aeson. +import qualified Data.Aeson as Aeson +-- Package: iproute. +import qualified Data.IP as IP +-- Package: network. +import qualified Network.DNS as DNS +import qualified Network.Socket as Socket +-- Package: text. +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TextEncoding +-- Package: self. +import qualified Cardano.Benchmarking.Topology.Types as Types + +-- Projection of a non-P2P topology. +-- To avoid having a "cardano-node" dependency, types were almost identically +-- copied from `Cardano.Node.Configuration.Topology`. +-------------------------------------------------------------------------------- + +{-- Example output: +{ + "Producers": [ + { + "addr": "127.0.0.1", + "port": 30001, + "valency": 1 + } + ] +} +--} + +----------------------------------------- +-- Cardano.Node.Configuration.Topology -- +----------------------------------------- + +-- https://github.com/IntersectMBO/cardano-node/blob/8d6b66e7bf93a0bba7fbfe44714c0fe30cd51ae5/cardano-node/src/Cardano/Node/Configuration/Topology.hs#L115 + +-- `NetworkTopology` without the `MockNodeTopology` constructor. +data NetworkTopology = RealNodeTopology ![RemoteAddress] + deriving (Eq, Show) + +instance Aeson.FromJSON NetworkTopology where + parseJSON = Aeson.withObject "NetworkTopology" $ \o -> RealNodeTopology + <$> o Aeson..: "Producers" + +instance Aeson.ToJSON NetworkTopology where + toJSON (RealNodeTopology ras) = + Aeson.object [ "Producers" Aeson..= Aeson.toJSON ras ] + +-- | Domain name with port number +-- +data RemoteAddress = RemoteAddress + { raAddress :: !Text.Text + -- ^ Either a dns address or an ip address. + , raPort :: !Socket.PortNumber + -- ^ Port number of the destination. + , raValency :: !Int + -- ^ If a DNS address is given valency governs + -- to how many resolved IP addresses + -- should we maintain active (hot) connection; + -- if an IP address is given valency is used as + -- a Boolean value, @0@ means to ignore the address; + } deriving (Eq, Ord, Show) + +instance Aeson.FromJSON RemoteAddress where + parseJSON = Aeson.withObject "RemoteAddress" $ \v -> RemoteAddress + <$> v Aeson..: "addr" + <*> ((fromIntegral :: Int -> Socket.PortNumber) <$> v Aeson..: "port") + <*> v Aeson..: "valency" + +instance Aeson.ToJSON RemoteAddress where + toJSON ra = Aeson.object + [ "addr" Aeson..= raAddress ra + , "port" Aeson..= (fromIntegral (raPort ra) :: Int) + , "valency" Aeson..= raValency ra + ] + +-- Projection of a P2P topology. +-- To avoid having a "cardano-node" dependency, types were almost identically +-- copied from `Cardano.Node.Configuration.TopologyP2P`. +-------------------------------------------------------------------------------- + +{-- Example: +{ + "localRoots": [ + { + "accessPoints": [ + { + "address": "127.0.0.1", + "port": 3001 + } + ], + "advertise": false, + "valency": 6 + } + ] + "publicRoots": [], + "useLedgerAfterSlot": -1 +} +--} + +-------------------------------------------- +-- Cardano.Node.Configuration.TopologyP2P -- +-------------------------------------------- + +-- https://github.com/IntersectMBO/cardano-node/blob/8d6b66e7bf93a0bba7fbfe44714c0fe30cd51ae5/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs#L174 + +-- Renamed `NetworkTopology`. +data NetworkTopologyP2P = RealNodeTopologyP2P + { ntLocalRootPeersGroups :: !LocalRootPeersGroups + , ntPublicRootPeers :: ![PublicRootPeers] + , ntUseLedgerPeers :: !UseLedgerPeers + , ntUseBootstrapPeers :: !UseBootstrapPeers + } + deriving (Eq, Show) + +instance Aeson.FromJSON NetworkTopologyP2P where + parseJSON = Aeson.withObject "NetworkTopologyP2P" $ \o -> RealNodeTopologyP2P + <$> (o Aeson..: "localRoots" ) + <*> (o Aeson..: "publicRoots" ) + <*> (o Aeson..:? "useLedgerAfterSlot" Aeson..!= DontUseLedgerPeers ) + <*> (o Aeson..:? "bootstrapPeers" Aeson..!= DontUseBootstrapPeers) + +instance Aeson.ToJSON NetworkTopologyP2P where + toJSON top = Aeson.object + [ "localRoots" Aeson..= ntLocalRootPeersGroups top + , "publicRoots" Aeson..= ntPublicRootPeers top + , "useLedgerAfterSlot" Aeson..= ntUseLedgerPeers top + , "bootstrapPeers" Aeson..= ntUseBootstrapPeers top + ] + +-- https://github.com/IntersectMBO/cardano-node/blob/8d6b66e7bf93a0bba7fbfe44714c0fe30cd51ae5/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs#L84 + +-- | Each root peer consists of a list of access points and a shared +-- 'PeerAdvertise' field. +-- +data RootConfig = RootConfig + { rootAccessPoints :: [RelayAccessPoint] + -- ^ a list of relay access points, each of which is either an ip address + -- or domain name and a port number. + , rootAdvertise :: PeerAdvertise + -- ^ 'advertise' configures whether the root should be advertised through + -- peer sharing. + } deriving (Eq, Show) + +instance Aeson.FromJSON RootConfig where + parseJSON = Aeson.withObject "RootConfig" $ \o -> RootConfig + <$> o Aeson..: "accessPoints" + <*> o Aeson..:? "advertise" Aeson..!= DoNotAdvertisePeer + +instance Aeson.ToJSON RootConfig where + toJSON ra = Aeson.object + [ "accessPoints" Aeson..= rootAccessPoints ra + , "advertise" Aeson..= rootAdvertise ra + ] + +-- https://github.com/IntersectMBO/cardano-node/blob/8d6b66e7bf93a0bba7fbfe44714c0fe30cd51ae5/cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs#L122 + +-- | A local root peers group. Local roots are treated by the outbound +-- governor in a special way. The node will make sure that a node has the +-- requested number ('valency'/'hotValency') of connections to the local root peer group. +-- 'warmValency' value is the value of warm/established connections that the node +-- will attempt to maintain. By default this value will be equal to 'hotValency'. +-- +data LocalRootPeersGroup = LocalRootPeersGroup + { localRoots :: RootConfig + , hotValency :: HotValency + , warmValency :: WarmValency + , trustable :: PeerTrustable + -- ^ 'trustable' configures whether the root should be trusted in fallback + -- state. + } deriving (Eq, Show) + +-- | Does not use the 'FromJSON' instance of 'RootConfig', so that +-- 'accessPoints', 'advertise', 'valency' and 'warmValency' fields are attached to the +-- same object. +instance Aeson.FromJSON LocalRootPeersGroup where + parseJSON = Aeson.withObject "LocalRootPeersGroup" $ \o -> do + hv@(HotValency v) <- o Aeson..: "valency" + <|> o Aeson..: "hotValency" + LocalRootPeersGroup + <$> Aeson.parseJSON (Aeson.Object o) + <*> pure hv + <*> o Aeson..:? "warmValency" Aeson..!= WarmValency v + <*> o Aeson..:? "trustable" Aeson..!= IsNotTrustable + +instance Aeson.ToJSON LocalRootPeersGroup where + toJSON lrpg = Aeson.object + [ "accessPoints" Aeson..= rootAccessPoints (localRoots lrpg) + , "advertise" Aeson..= rootAdvertise (localRoots lrpg) + , "hotValency" Aeson..= hotValency lrpg + , "warmValency" Aeson..= warmValency lrpg + , "trustable" Aeson..= trustable lrpg + ] + +newtype LocalRootPeersGroups = LocalRootPeersGroups + { groups :: [LocalRootPeersGroup] + } deriving (Eq, Show) + +instance Aeson.FromJSON LocalRootPeersGroups where + parseJSON = fmap LocalRootPeersGroups . Aeson.parseJSONList + +instance Aeson.ToJSON LocalRootPeersGroups where + toJSON = Aeson.toJSONList . groups + +newtype PublicRootPeers = PublicRootPeers + { publicRoots :: RootConfig + } deriving (Eq, Show) + +instance Aeson.FromJSON PublicRootPeers where + parseJSON = fmap PublicRootPeers . Aeson.parseJSON + +instance Aeson.ToJSON PublicRootPeers where + toJSON = Aeson.toJSON . publicRoots + +------------------------------------------------------ +-- Ouroboros.Network.PeerSelection.RelayAccessPoint -- +------------------------------------------------------ + +-- https://github.com/IntersectMBO/ouroboros-network/blob/faf4c69b8a704ade5e19ec4abad0144fcbfce380/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs#L58 + +data RelayAccessPoint = + RelayAccessDomain !DNS.Domain !Socket.PortNumber + | RelayAccessAddress !IP.IP !Socket.PortNumber + deriving (Eq, Ord, Show) + +-- https://github.com/IntersectMBO/ouroboros-network/blob/faf4c69b8a704ade5e19ec4abad0144fcbfce380/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/RelayAccessPoint.hs#L142 + +instance Aeson.FromJSON RelayAccessPoint where + parseJSON = Aeson.withObject "RelayAccessPoint" $ \v -> do + addr <- v Aeson..: "address" + port <- v Aeson..: "port" + return (toRelayAccessPoint addr port) + +instance Aeson.ToJSON RelayAccessPoint where + toJSON (RelayAccessDomain addr port) = Aeson.object + [ "address" Aeson..= TextEncoding.decodeUtf8 addr + , "port" Aeson..= (fromIntegral port :: Int) + ] + toJSON (RelayAccessAddress ip port) = Aeson.object + [ "address" Aeson..= Text.pack (show ip) + , "port" Aeson..= (fromIntegral port :: Int) + ] + +-- | Parse a address field as either an IP address or a DNS address. +-- Returns corresponding RelayAccessPoint. +-- +toRelayAccessPoint :: Text.Text -> Int -> RelayAccessPoint +toRelayAccessPoint address port = + case readMaybe (Text.unpack address) of + Nothing -> RelayAccessDomain + (TextEncoding.encodeUtf8 address) + (fromIntegral port) + Just addr -> RelayAccessAddress addr (fromIntegral port) + +-- Ouroboros.Network.PeerSelection.PeerAdvertise +------------------------------------------------ + +-- | Should this peer be advertised to other peers asking for known peers? +-- For certain peers specified by configuration it would be an appropriate +-- policy to keep them private. +-- +data PeerAdvertise = + DoNotAdvertisePeer + | DoAdvertisePeer + deriving (Eq, Show, Ord) + +instance Aeson.FromJSON PeerAdvertise where + parseJSON = Aeson.withBool "PeerAdvertise" $ + return . bool DoNotAdvertisePeer DoAdvertisePeer + +instance Aeson.ToJSON PeerAdvertise where + toJSON DoAdvertisePeer = Aeson.Bool True + toJSON DoNotAdvertisePeer = Aeson.Bool False + +------------------------------------------------------ +-- Ouroboros.Network.PeerSelection.LedgerPeers.Type -- +------------------------------------------------------ + +-- https://github.com/IntersectMBO/ouroboros-network/blob/faf4c69b8a704ade5e19ec4abad0144fcbfce380/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/LedgerPeers/Type.hs#L192 +-- | Only use the ledger after the given slot number. +data UseLedgerPeers = + DontUseLedgerPeers + | UseLedgerPeers AfterSlot + deriving (Eq, Show, Generic) + +-- | Only use the ledger after the given slot number. +data AfterSlot = + Always + | After SlotNo + deriving (Eq, Show) + +-- `FromJSON`/`ToJSON` from " Cardano.Tracing.OrphanInstances.Network". + +-- https://github.com/IntersectMBO/cardano-node/blob/8d6b66e7bf93a0bba7fbfe44714c0fe30cd51ae5/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs#L2615 + +instance Aeson.FromJSON UseLedgerPeers where + parseJSON (Aeson.Number slot) = return $ + case compare slot 0 of + GT -> UseLedgerPeers (After (SlotNo (floor slot))) + EQ -> UseLedgerPeers Always + LT -> DontUseLedgerPeers + parseJSON invalid = fail $ "Parsing of slot number failed due to type mismatch. " + <> "Encountered: " <> show invalid + +-- https://github.com/IntersectMBO/cardano-node/blob/8d6b66e7bf93a0bba7fbfe44714c0fe30cd51ae5/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs#L2633C1-L2636C71 +instance Aeson.ToJSON UseLedgerPeers where + toJSON DontUseLedgerPeers = Aeson.Number (-1) + toJSON (UseLedgerPeers Always) = Aeson.Number 0 + toJSON (UseLedgerPeers (After (SlotNo s))) = Aeson.Number (fromIntegral s) + +--------------------------- +-- Cardano.Slotting.Slot -- +--------------------------- + +-- | The 0-based index for the Ourboros time slot. +newtype SlotNo = SlotNo {unSlotNo :: Word64} + deriving (Eq, Ord, Show) + +---------------------------------------------------------- +-- Ouroboros.Network.PeerSelection.State.LocalRootPeers -- +---------------------------------------------------------- + +-- https://github.com/IntersectMBO/ouroboros-network/blob/faf4c69b8a704ade5e19ec4abad0144fcbfce380/ouroboros-network/src/Ouroboros/Network/PeerSelection/State/LocalRootPeers.hs#L65 + +newtype HotValency = HotValency { getHotValency :: Int } + deriving (Show, Eq, Ord) + +-- | Newtype wrapper representing warm valency value from local root group +-- configuration +-- +newtype WarmValency = WarmValency { getWarmValency :: Int } + deriving (Show, Eq, Ord) + +-- `FromJSON`/`ToJSON` from " Cardano.Tracing.OrphanInstances.Network". + +-- https://github.com/IntersectMBO/cardano-node/blob/8d6b66e7bf93a0bba7fbfe44714c0fe30cd51ae5/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs#L1483 + +instance Aeson.ToJSON HotValency where + toJSON (HotValency v) = Aeson.toJSON v + +instance Aeson.ToJSON WarmValency where + toJSON (WarmValency v) = Aeson.toJSON v + +instance Aeson.FromJSON HotValency where + parseJSON v = HotValency <$> Aeson.parseJSON v + +instance Aeson.FromJSON WarmValency where + parseJSON v = WarmValency <$> Aeson.parseJSON v + +--------------------------------------------------- +-- Ouroboros.Network.PeerSelection.PeerTrustable -- +--------------------------------------------------- + +-- https://github.com/IntersectMBO/ouroboros-network/blob/faf4c69b8a704ade5e19ec4abad0144fcbfce380/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerTrustable.hs#L13 + +-- | Is this Peer trustable as a bootstrap peer? +-- +-- This trustability flag is used on local root peers (pre-genesis) to +-- distinguish which locally configured peer is considered safe to trust for +-- bootstrap purposes +-- +data PeerTrustable = + IsTrustable + | IsNotTrustable + deriving (Eq, Show, Ord, Generic) + +-- `FromJSON`/`ToJSON` from " Cardano.Tracing.OrphanInstances.Network". + +-- https://github.com/IntersectMBO/cardano-node/blob/8d6b66e7bf93a0bba7fbfe44714c0fe30cd51ae5/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs#L2646C1-L2653C37 + +instance Aeson.FromJSON PeerTrustable where + parseJSON = Aeson.withBool "PeerTrustable" $ \b -> + pure $ if b then IsTrustable + else IsNotTrustable + +instance Aeson.ToJSON PeerTrustable where + toJSON IsTrustable = Aeson.Bool True + toJSON IsNotTrustable = Aeson.Bool False + +----------------------------------------------- +-- Ouroboros.Network.PeerSelection.Bootstrap -- +----------------------------------------------- + +-- https://github.com/IntersectMBO/ouroboros-network/blob/faf4c69b8a704ade5e19ec4abad0144fcbfce380/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/Bootstrap.hs#L16 + +data UseBootstrapPeers = + DontUseBootstrapPeers + | UseBootstrapPeers [RelayAccessPoint] + deriving (Eq, Show, Ord, Generic) + +-- `FromJSON`/`ToJSON` from " Cardano.Tracing.OrphanInstances.Network". + +-- https://github.com/IntersectMBO/cardano-node/blob/8d6b66e7bf93a0bba7fbfe44714c0fe30cd51ae5/cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs#L2638 + +instance Aeson.ToJSON UseBootstrapPeers where + toJSON DontUseBootstrapPeers = Aeson.Null + toJSON (UseBootstrapPeers dps) = Aeson.toJSON dps + +instance Aeson.FromJSON UseBootstrapPeers where + parseJSON Aeson.Null = pure DontUseBootstrapPeers + parseJSON v = UseBootstrapPeers <$> Aeson.parseJSON v + +-------------------------------------------------------------------------------- + +getCoreNodeProducersById :: Types.Topology -> Int -> [String] +getCoreNodeProducersById topology i = Types.producers $ + (!! 0) $ + filter + ((== i) . Types.nodeId) + (Types.coreNodes topology) + +getCoreNodeByName :: Types.Topology -> String -> Types.Node +getCoreNodeByName topology name = + (!! 0) $ + filter + ((== name) . Types.name) + (Types.coreNodes topology) + +projection :: Types.Topology -> Int -> Int -> NetworkTopology +projection topology i basePort = RealNodeTopology $ + map + (\name -> + let node = getCoreNodeByName topology name + in RemoteAddress { + raAddress = "127.0.0.1" + , raPort = toEnum (basePort + Types.nodeId node) + , raValency = 1 + } + ) + (getCoreNodeProducersById topology i) + +projectionP2P :: Types.Topology -> Int -> Int -> NetworkTopologyP2P +projectionP2P topology i basePort = RealNodeTopologyP2P + { + ntLocalRootPeersGroups = LocalRootPeersGroups { + groups = + map + (\name -> + let node = getCoreNodeByName topology name + in LocalRootPeersGroup { + localRoots = RootConfig { + rootAccessPoints = [ + RelayAccessAddress + "127.0.0.1" + (toEnum $ basePort + Types.nodeId node) + ] + , rootAdvertise = DoNotAdvertisePeer + } + , hotValency = HotValency (-1) + , warmValency = WarmValency (-1) + , trustable = IsNotTrustable + } + ) + (getCoreNodeProducersById topology i) + } + , ntPublicRootPeers = [] + , ntUseLedgerPeers = DontUseLedgerPeers + , ntUseBootstrapPeers = DontUseBootstrapPeers + } diff --git a/nix/workbench/default.nix b/nix/workbench/default.nix index f2500e697d1..5dec74ce2ef 100644 --- a/nix/workbench/default.nix +++ b/nix/workbench/default.nix @@ -86,6 +86,13 @@ let '' ; + runCardanoTopology = + name: command: # Name of derivation and `cardano-profile` command to run. + pkgs.runCommand name {} '' + ${cardanoNodePackages.cardano-topology}/bin/cardano-topology ${command} > $out + '' + ; + runJq = name: args: query: pkgs.runCommand name {} ''