{-# 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 (..))
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
]
data RootConfig = RootConfig
{ RootConfig -> [RelayAccessPoint]
rootAccessPoints :: [RelayAccessPoint]
, RootConfig -> PeerAdvertise
rootAdvertise :: PeerAdvertise
} 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
]
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 ]
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)
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
]
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))
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
_) ->
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