{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}

module Cardano.Node.Configuration.TopologyP2P
  ( TopologyError(..)
  , NetworkTopology(..)
  , PublicRootPeers(..)
  , LocalRootPeersGroup(..)
  , LocalRootPeersGroups(..)
  , RootConfig(..)
  , NodeHostIPAddress(..)
  , NodeHostIPv4Address(..)
  , NodeHostIPv6Address(..)
  , NodeSetup(..)
  , PeerAdvertise(..)
  , UseLedger(..)
  , nodeAddressToSockAddr
  , readTopologyFile
  , readTopologyFileOrError
  , rootConfigToRelayAccessPoint
  )
where

import           Control.Exception (IOException)
import qualified Control.Exception as Exception
import           Control.Exception.Base (Exception (..))
import           Control.Monad (MonadPlus (..))
import           Data.Aeson
import           Data.Bifunctor (Bifunctor (..))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import           Data.Text (Text)
import qualified Data.Text as Text
import           Data.Word (Word64)

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.Configuration.Topology (TopologyError (..))
import           Cardano.Node.Startup (StartupTrace (..))
import           Cardano.Node.Types

import           Ouroboros.Network.NodeToNode (PeerAdvertise (..))
import           Ouroboros.Network.PeerSelection.LedgerPeers (UseLedgerAfter (..))
import           Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..))



-- | A newtype wrapper around 'UseLedgerAfter' which provides 'FromJSON' and
-- 'ToJSON' instances.
--
-- 'UseLedgerAfter' is used to configure from which slot a p2p node can use on
-- chain root peers.
--
newtype UseLedger = UseLedger UseLedgerAfter deriving (UseLedger -> UseLedger -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UseLedger -> UseLedger -> Bool
$c/= :: UseLedger -> UseLedger -> Bool
== :: UseLedger -> UseLedger -> Bool
$c== :: UseLedger -> UseLedger -> Bool
Eq, Int -> UseLedger -> ShowS
[UseLedger] -> ShowS
UseLedger -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UseLedger] -> ShowS
$cshowList :: [UseLedger] -> ShowS
show :: UseLedger -> String
$cshow :: UseLedger -> String
showsPrec :: Int -> UseLedger -> ShowS
$cshowsPrec :: Int -> UseLedger -> ShowS
Show)

instance FromJSON UseLedger where
  parseJSON :: Value -> Parser UseLedger
parseJSON (Data.Aeson.Number Scientific
n) =
    if Scientific
n forall a. Ord a => a -> a -> Bool
>= Scientific
0 then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ UseLedgerAfter -> UseLedger
UseLedger forall a b. (a -> b) -> a -> b
$ SlotNo -> UseLedgerAfter
UseLedgerAfter forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNo
SlotNo forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
floor Scientific
n
              else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ UseLedgerAfter -> UseLedger
UseLedger   UseLedgerAfter
DontUseLedger
  parseJSON Value
_ = forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance ToJSON UseLedger where
  toJSON :: UseLedger -> Value
toJSON (UseLedger (UseLedgerAfter (SlotNo Word64
n))) = Scientific -> Value
Number forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n
  toJSON (UseLedger UseLedgerAfter
DontUseLedger)               = Scientific -> Value
Number (-Scientific
1)

data NodeSetup = NodeSetup
  { NodeSetup -> Word64
nodeId          :: !Word64
  , NodeSetup -> Maybe NodeIPv4Address
nodeIPv4Address :: !(Maybe NodeIPv4Address)
  , NodeSetup -> Maybe NodeIPv6Address
nodeIPv6Address :: !(Maybe NodeIPv6Address)
  , NodeSetup -> [RootConfig]
producers       :: ![RootConfig]
  , NodeSetup -> UseLedger
useLedger       :: !UseLedger
  } deriving (NodeSetup -> NodeSetup -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NodeSetup -> NodeSetup -> Bool
$c/= :: NodeSetup -> NodeSetup -> Bool
== :: NodeSetup -> NodeSetup -> Bool
$c== :: NodeSetup -> NodeSetup -> Bool
Eq, Int -> NodeSetup -> ShowS
[NodeSetup] -> ShowS
NodeSetup -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NodeSetup] -> ShowS
$cshowList :: [NodeSetup] -> ShowS
show :: NodeSetup -> String
$cshow :: NodeSetup -> String
showsPrec :: Int -> NodeSetup -> ShowS
$cshowsPrec :: Int -> NodeSetup -> ShowS
Show)

instance FromJSON NodeSetup where
  parseJSON :: Value -> Parser NodeSetup
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"NodeSetup" forall a b. (a -> b) -> a -> b
$ \Object
o ->
                Word64
-> Maybe NodeIPv4Address
-> Maybe NodeIPv6Address
-> [RootConfig]
-> UseLedger
-> NodeSetup
NodeSetup
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"nodeId"
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"nodeIPv4Address"
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"nodeIPv6Address"
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"producers"
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"useLedgerAfterSlot" forall a. Parser (Maybe a) -> a -> Parser a
.!= UseLedgerAfter -> UseLedger
UseLedger UseLedgerAfter
DontUseLedger

instance ToJSON NodeSetup where
  toJSON :: NodeSetup -> Value
toJSON NodeSetup
ns =
    [Pair] -> Value
object
      [ Key
"nodeId"             forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NodeSetup -> Word64
nodeId NodeSetup
ns
      , Key
"nodeIPv4Address"    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NodeSetup -> Maybe NodeIPv4Address
nodeIPv4Address NodeSetup
ns
      , Key
"nodeIPv6Address"    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NodeSetup -> Maybe NodeIPv6Address
nodeIPv6Address NodeSetup
ns
      , Key
"producers"          forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NodeSetup -> [RootConfig]
producers NodeSetup
ns
      , Key
"useLedgerAfterSlot" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NodeSetup -> UseLedger
useLedger NodeSetup
ns
      ]


-- | Each root peer consists of a list of access points and a shared
-- 'PeerAdvertise' field.
--
data RootConfig = RootConfig
  { RootConfig -> [RelayAccessPoint]
rootAccessPoints :: [RelayAccessPoint]
    -- ^ a list of relay access points, each of which is either an ip address
    -- or domain name and a port number.
  , RootConfig -> PeerAdvertise
rootAdvertise    :: PeerAdvertise
    -- ^ 'advertise' configures whether the root should be advertised through
    -- gossip.
  } deriving (RootConfig -> RootConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RootConfig -> RootConfig -> Bool
$c/= :: RootConfig -> RootConfig -> Bool
== :: RootConfig -> RootConfig -> Bool
$c== :: RootConfig -> RootConfig -> Bool
Eq, Int -> RootConfig -> ShowS
[RootConfig] -> ShowS
RootConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RootConfig] -> ShowS
$cshowList :: [RootConfig] -> ShowS
show :: RootConfig -> String
$cshow :: RootConfig -> String
showsPrec :: Int -> RootConfig -> ShowS
$cshowsPrec :: Int -> RootConfig -> ShowS
Show)

instance FromJSON RootConfig where
  parseJSON :: Value -> Parser RootConfig
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RootConfig" forall a b. (a -> b) -> a -> b
$ \Object
o ->
                [RelayAccessPoint] -> PeerAdvertise -> RootConfig
RootConfig
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.:  Key
"accessPoints"
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"advertise" forall a. Parser (Maybe a) -> a -> Parser a
.!= PeerAdvertise
DoNotAdvertisePeer

instance ToJSON RootConfig where
  toJSON :: RootConfig -> Value
toJSON RootConfig
ra =
    [Pair] -> Value
object
      [ Key
"accessPoints" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RootConfig -> [RelayAccessPoint]
rootAccessPoints RootConfig
ra
      , Key
"advertise"    forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RootConfig -> PeerAdvertise
rootAdvertise RootConfig
ra
      ]

-- | Transforms a 'RootConfig' into a pair of 'RelayAccessPoint' and its
-- corresponding 'PeerAdvertise' value.
--
rootConfigToRelayAccessPoint
  :: RootConfig
  -> [(RelayAccessPoint, PeerAdvertise)]
rootConfigToRelayAccessPoint :: RootConfig -> [(RelayAccessPoint, PeerAdvertise)]
rootConfigToRelayAccessPoint RootConfig { [RelayAccessPoint]
rootAccessPoints :: [RelayAccessPoint]
rootAccessPoints :: RootConfig -> [RelayAccessPoint]
rootAccessPoints, PeerAdvertise
rootAdvertise :: PeerAdvertise
rootAdvertise :: RootConfig -> PeerAdvertise
rootAdvertise } =
    [ (RelayAccessPoint
ap, PeerAdvertise
rootAdvertise) | RelayAccessPoint
ap <- [RelayAccessPoint]
rootAccessPoints ]


-- | 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') of connections to the local root peer group.
--
data LocalRootPeersGroup = LocalRootPeersGroup
  { LocalRootPeersGroup -> RootConfig
localRoots :: RootConfig
  , LocalRootPeersGroup -> Int
valency    :: Int
  } deriving (LocalRootPeersGroup -> LocalRootPeersGroup -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LocalRootPeersGroup -> LocalRootPeersGroup -> Bool
$c/= :: LocalRootPeersGroup -> LocalRootPeersGroup -> Bool
== :: LocalRootPeersGroup -> LocalRootPeersGroup -> Bool
$c== :: LocalRootPeersGroup -> LocalRootPeersGroup -> Bool
Eq, Int -> LocalRootPeersGroup -> ShowS
[LocalRootPeersGroup] -> ShowS
LocalRootPeersGroup -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LocalRootPeersGroup] -> ShowS
$cshowList :: [LocalRootPeersGroup] -> ShowS
show :: LocalRootPeersGroup -> String
$cshow :: LocalRootPeersGroup -> String
showsPrec :: Int -> LocalRootPeersGroup -> ShowS
$cshowsPrec :: Int -> LocalRootPeersGroup -> ShowS
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 :: Value -> Parser LocalRootPeersGroup
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"LocalRootPeersGroup" forall a b. (a -> b) -> a -> b
$ \Object
o ->
                RootConfig -> Int -> LocalRootPeersGroup
LocalRootPeersGroup
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Object Object
o)
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"valency"

instance ToJSON LocalRootPeersGroup where
  toJSON :: LocalRootPeersGroup -> Value
toJSON LocalRootPeersGroup
lrpg =
    [Pair] -> Value
object
      [ Key
"accessPoints" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RootConfig -> [RelayAccessPoint]
rootAccessPoints (LocalRootPeersGroup -> RootConfig
localRoots LocalRootPeersGroup
lrpg)
      , Key
"advertise" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RootConfig -> PeerAdvertise
rootAdvertise (LocalRootPeersGroup -> RootConfig
localRoots LocalRootPeersGroup
lrpg)
      , Key
"valency" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LocalRootPeersGroup -> Int
valency LocalRootPeersGroup
lrpg
      ]

newtype LocalRootPeersGroups = LocalRootPeersGroups
  { LocalRootPeersGroups -> [LocalRootPeersGroup]
groups :: [LocalRootPeersGroup]
  } deriving (LocalRootPeersGroups -> LocalRootPeersGroups -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LocalRootPeersGroups -> LocalRootPeersGroups -> Bool
$c/= :: LocalRootPeersGroups -> LocalRootPeersGroups -> Bool
== :: LocalRootPeersGroups -> LocalRootPeersGroups -> Bool
$c== :: LocalRootPeersGroups -> LocalRootPeersGroups -> Bool
Eq, Int -> LocalRootPeersGroups -> ShowS
[LocalRootPeersGroups] -> ShowS
LocalRootPeersGroups -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LocalRootPeersGroups] -> ShowS
$cshowList :: [LocalRootPeersGroups] -> ShowS
show :: LocalRootPeersGroups -> String
$cshow :: LocalRootPeersGroups -> String
showsPrec :: Int -> LocalRootPeersGroups -> ShowS
$cshowsPrec :: Int -> LocalRootPeersGroups -> ShowS
Show)

instance FromJSON LocalRootPeersGroups where
  parseJSON :: Value -> Parser LocalRootPeersGroups
parseJSON = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [LocalRootPeersGroup] -> LocalRootPeersGroups
LocalRootPeersGroups forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser [a]
parseJSONList

instance ToJSON LocalRootPeersGroups where
  toJSON :: LocalRootPeersGroups -> Value
toJSON = forall a. ToJSON a => [a] -> Value
toJSONList forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalRootPeersGroups -> [LocalRootPeersGroup]
groups

newtype PublicRootPeers = PublicRootPeers
  { PublicRootPeers -> RootConfig
publicRoots :: RootConfig
  } deriving (PublicRootPeers -> PublicRootPeers -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PublicRootPeers -> PublicRootPeers -> Bool
$c/= :: PublicRootPeers -> PublicRootPeers -> Bool
== :: PublicRootPeers -> PublicRootPeers -> Bool
$c== :: PublicRootPeers -> PublicRootPeers -> Bool
Eq, Int -> PublicRootPeers -> ShowS
[PublicRootPeers] -> ShowS
PublicRootPeers -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PublicRootPeers] -> ShowS
$cshowList :: [PublicRootPeers] -> ShowS
show :: PublicRootPeers -> String
$cshow :: PublicRootPeers -> String
showsPrec :: Int -> PublicRootPeers -> ShowS
$cshowsPrec :: Int -> PublicRootPeers -> ShowS
Show)

instance FromJSON PublicRootPeers where
  parseJSON :: Value -> Parser PublicRootPeers
parseJSON = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RootConfig -> PublicRootPeers
PublicRootPeers forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser a
parseJSON

instance ToJSON PublicRootPeers where
  toJSON :: PublicRootPeers -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicRootPeers -> RootConfig
publicRoots

data NetworkTopology = RealNodeTopology !LocalRootPeersGroups ![PublicRootPeers] !UseLedger
  deriving (NetworkTopology -> NetworkTopology -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NetworkTopology -> NetworkTopology -> Bool
$c/= :: NetworkTopology -> NetworkTopology -> Bool
== :: NetworkTopology -> NetworkTopology -> Bool
$c== :: NetworkTopology -> NetworkTopology -> Bool
Eq, Int -> NetworkTopology -> ShowS
[NetworkTopology] -> ShowS
NetworkTopology -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NetworkTopology] -> ShowS
$cshowList :: [NetworkTopology] -> ShowS
show :: NetworkTopology -> String
$cshow :: NetworkTopology -> String
showsPrec :: Int -> NetworkTopology -> ShowS
$cshowsPrec :: Int -> NetworkTopology -> ShowS
Show)

instance FromJSON NetworkTopology where
  parseJSON :: Value -> Parser NetworkTopology
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"NetworkTopology" forall a b. (a -> b) -> a -> b
$ \Object
o ->
                LocalRootPeersGroups
-> [PublicRootPeers] -> UseLedger -> NetworkTopology
RealNodeTopology forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"localRoots"                                     )
                                 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"publicRoots"                                    )
                                 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"useLedgerAfterSlot" forall a. Parser (Maybe a) -> a -> Parser a
.!= UseLedgerAfter -> UseLedger
UseLedger UseLedgerAfter
DontUseLedger)

instance ToJSON NetworkTopology where
  toJSON :: NetworkTopology -> Value
toJSON NetworkTopology
top =
    case NetworkTopology
top of
      RealNodeTopology LocalRootPeersGroups
lrpg [PublicRootPeers]
prp UseLedger
ul -> [Pair] -> Value
object [ Key
"localRoots"         forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LocalRootPeersGroups
lrpg
                                             , Key
"publicRoots"        forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [PublicRootPeers]
prp
                                             , Key
"useLedgerAfterSlot" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UseLedger
ul
                                             ]

--
-- Legacy p2p topology file format
--

-- | A newtype wrapper which provides legacy 'FromJSON' instances.
--
newtype Legacy a = Legacy { forall a. Legacy a -> a
getLegacy :: a }

instance FromJSON (Legacy a) => FromJSON (Legacy [a]) where
  parseJSON :: Value -> Parser (Legacy [a])
parseJSON = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Legacy a
Legacy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Legacy a -> a
getLegacy) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser [a]
parseJSONList

instance FromJSON (Legacy LocalRootPeersGroup) where
  parseJSON :: Value -> Parser (Legacy LocalRootPeersGroup)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"LocalRootPeersGroup" forall a b. (a -> b) -> a -> b
$ \Object
o ->
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Legacy a
Legacy forall a b. (a -> b) -> a -> b
$ RootConfig -> Int -> LocalRootPeersGroup
LocalRootPeersGroup
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"localRoots"
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"valency"

instance FromJSON (Legacy LocalRootPeersGroups) where
  parseJSON :: Value -> Parser (Legacy LocalRootPeersGroups)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"LocalRootPeersGroups" forall a b. (a -> b) -> a -> b
$ \Object
o ->
                forall a. a -> Legacy a
Legacy forall b c a. (b -> c) -> (a -> b) -> a -> c
. [LocalRootPeersGroup] -> LocalRootPeersGroups
LocalRootPeersGroups forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Legacy a -> a
getLegacy
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"groups"

instance FromJSON (Legacy PublicRootPeers) where
  parseJSON :: Value -> Parser (Legacy PublicRootPeers)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"PublicRootPeers" forall a b. (a -> b) -> a -> b
$ \Object
o ->
                forall a. a -> Legacy a
Legacy forall b c a. (b -> c) -> (a -> b) -> a -> c
. RootConfig -> PublicRootPeers
PublicRootPeers
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"publicRoots"

instance FromJSON (Legacy NetworkTopology) where
  parseJSON :: Value -> Parser (Legacy NetworkTopology)
parseJSON = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Legacy a
Legacy
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"NetworkTopology" (\Object
o ->
                LocalRootPeersGroups
-> [PublicRootPeers] -> UseLedger -> NetworkTopology
RealNodeTopology forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Legacy a -> a
getLegacy (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"LocalRoots")
                                 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Legacy a -> a
getLegacy (Object
o forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"PublicRoots")
                                 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"useLedgerAfterSlot" forall a. Parser (Maybe a) -> a -> Parser a
.!= UseLedgerAfter -> UseLedger
UseLedger UseLedgerAfter
DontUseLedger))

-- | Read the `NetworkTopology` configuration from the specified file.
--
readTopologyFile :: Tracer IO (StartupTrace blk)
                 -> NodeConfiguration -> IO (Either Text NetworkTopology)
readTopologyFile :: forall blk.
Tracer IO (StartupTrace blk)
-> NodeConfiguration -> IO (Either Text NetworkTopology)
readTopologyFile Tracer IO (StartupTrace blk)
tr NodeConfiguration
nc = do
  Either IOException ByteString
eBs <- forall e a. Exception e => IO a -> IO (Either e a)
Exception.try forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile (TopologyFile -> String
unTopology forall a b. (a -> b) -> a -> b
$ NodeConfiguration -> TopologyFile
ncTopologyFile NodeConfiguration
nc)

  case Either IOException ByteString
eBs of
    Left IOException
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ IOException -> Text
handler IOException
e
    Right ByteString
bs ->
      let bs' :: ByteString
bs' = ByteString -> ByteString
LBS.fromStrict ByteString
bs in
      forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
handlerJSON (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs')
      Either Text NetworkTopology
-> Either Text (Legacy NetworkTopology)
-> IO (Either Text NetworkTopology)
`combine`
      forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
handlerJSON (forall a. FromJSON a => ByteString -> Either String a
eitherDecode ByteString
bs')

 where
  combine :: Either Text NetworkTopology
          -> Either Text (Legacy NetworkTopology)
          -> IO (Either Text NetworkTopology)
  combine :: Either Text NetworkTopology
-> Either Text (Legacy NetworkTopology)
-> IO (Either Text NetworkTopology)
combine Either Text NetworkTopology
a Either Text (Legacy NetworkTopology)
b = case (Either Text NetworkTopology
a, Either Text (Legacy NetworkTopology)
b) of
    (Right {}, Either Text (Legacy NetworkTopology)
_)     -> forall (m :: * -> *) a. Monad m => a -> m a
return Either Text NetworkTopology
a
    (Either Text NetworkTopology
_, Right {})     -> forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (StartupTrace blk)
tr forall blk. StartupTrace blk
NetworkConfigLegacy
                           forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Legacy a -> a
getLegacy forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text (Legacy NetworkTopology)
b)
    (Left Text
_, Left Text
_)  -> -- ignore parsing error of legacy format
                         forall (m :: * -> *) a. Monad m => a -> m a
return Either Text NetworkTopology
a

  handler :: IOException -> Text
  handler :: IOException -> Text
handler IOException
e = String -> Text
Text.pack forall a b. (a -> b) -> a -> b
$ String
"Cardano.Node.Configuration.Topology.readTopologyFile: "
                        forall a. [a] -> [a] -> [a]
++ forall e. Exception e => e -> String
displayException IOException
e
  handlerJSON :: String -> Text
  handlerJSON :: String -> Text
handlerJSON String
err = forall a. Monoid a => [a] -> a
mconcat
    [ Text
"Is your topology file formatted correctly? "
    , Text
"Expecting P2P Topology file format. "
    , Text
"The port and valency fields should be numerical. "
    , Text
"If you specified the correct topology file "
    , Text
"make sure that you correctly setup EnableP2P "
    , Text
"configuration flag. "
    , String -> Text
Text.pack String
err
    ]

readTopologyFileOrError :: Tracer IO (StartupTrace blk)
                        -> NodeConfiguration -> IO NetworkTopology
readTopologyFileOrError :: forall blk.
Tracer IO (StartupTrace blk)
-> NodeConfiguration -> IO NetworkTopology
readTopologyFileOrError Tracer IO (StartupTrace blk)
tr NodeConfiguration
nc =
      forall blk.
Tracer IO (StartupTrace blk)
-> NodeConfiguration -> IO (Either Text NetworkTopology)
readTopologyFile Tracer IO (StartupTrace blk)
tr NodeConfiguration
nc
  forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
err -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Cardano.Node.Configuration.TopologyP2P.readTopologyFile: "
                           forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
err)
             forall (f :: * -> *) a. Applicative f => a -> f a
pure