{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Cardano.Node.Configuration.TopologyP2P
( TopologyError(..)
, NetworkTopology(..)
, PublicRootPeers(..)
, LocalRootPeersGroup(..)
, LocalRootPeersGroups(..)
, RootConfig(..)
, NodeHostIPAddress(..)
, NodeHostIPv4Address(..)
, NodeHostIPv6Address(..)
, NodeSetup(..)
, PeerAdvertise(..)
, UseLedger(..)
, nodeAddressToSockAddr
, readTopologyFile
, readTopologyFileOrError
, rootConfigToRelayAccessPoint
)
where
import Cardano.Prelude hiding (ap)
import Prelude (String)
import qualified Control.Exception as Exception
import Data.Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.Text as Text
import Cardano.Node.Configuration.POM (NodeConfiguration (..))
import Cardano.Slotting.Slot (SlotNo (..))
import Cardano.Node.Configuration.NodeAddress
import Cardano.Node.Types
import Cardano.Node.Configuration.Topology (TopologyError (..))
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
(UseLedger -> UseLedger -> Bool)
-> (UseLedger -> UseLedger -> Bool) -> Eq UseLedger
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
(Int -> UseLedger -> ShowS)
-> (UseLedger -> String)
-> ([UseLedger] -> ShowS)
-> Show UseLedger
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 Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
>= Scientific
0 then UseLedger -> Parser UseLedger
forall (m :: * -> *) a. Monad m => a -> m a
return (UseLedger -> Parser UseLedger) -> UseLedger -> Parser UseLedger
forall a b. (a -> b) -> a -> b
$ UseLedgerAfter -> UseLedger
UseLedger (UseLedgerAfter -> UseLedger) -> UseLedgerAfter -> UseLedger
forall a b. (a -> b) -> a -> b
$ SlotNo -> UseLedgerAfter
UseLedgerAfter (SlotNo -> UseLedgerAfter) -> SlotNo -> UseLedgerAfter
forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Word64 -> SlotNo
forall a b. (a -> b) -> a -> b
$ Scientific -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
floor Scientific
n
else UseLedger -> Parser UseLedger
forall (m :: * -> *) a. Monad m => a -> m a
return (UseLedger -> Parser UseLedger) -> UseLedger -> Parser UseLedger
forall a b. (a -> b) -> a -> b
$ UseLedgerAfter -> UseLedger
UseLedger UseLedgerAfter
DontUseLedger
parseJSON Value
_ = Parser UseLedger
forall (m :: * -> *) a. MonadPlus m => m a
mzero
instance ToJSON UseLedger where
toJSON :: UseLedger -> Value
toJSON (UseLedger (UseLedgerAfter (SlotNo Word64
n))) = Scientific -> Value
Number (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ Word64 -> Scientific
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
(NodeSetup -> NodeSetup -> Bool)
-> (NodeSetup -> NodeSetup -> Bool) -> Eq NodeSetup
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
(Int -> NodeSetup -> ShowS)
-> (NodeSetup -> String)
-> ([NodeSetup] -> ShowS)
-> Show NodeSetup
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 = String -> (Object -> Parser NodeSetup) -> Value -> Parser NodeSetup
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"NodeSetup" ((Object -> Parser NodeSetup) -> Value -> Parser NodeSetup)
-> (Object -> Parser NodeSetup) -> Value -> Parser NodeSetup
forall a b. (a -> b) -> a -> b
$ \Object
o ->
Word64
-> Maybe NodeIPv4Address
-> Maybe NodeIPv6Address
-> [RootConfig]
-> UseLedger
-> NodeSetup
NodeSetup
(Word64
-> Maybe NodeIPv4Address
-> Maybe NodeIPv6Address
-> [RootConfig]
-> UseLedger
-> NodeSetup)
-> Parser Word64
-> Parser
(Maybe NodeIPv4Address
-> Maybe NodeIPv6Address -> [RootConfig] -> UseLedger -> NodeSetup)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Word64
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"nodeId"
Parser
(Maybe NodeIPv4Address
-> Maybe NodeIPv6Address -> [RootConfig] -> UseLedger -> NodeSetup)
-> Parser (Maybe NodeIPv4Address)
-> Parser
(Maybe NodeIPv6Address -> [RootConfig] -> UseLedger -> NodeSetup)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe NodeIPv4Address)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"nodeIPv4Address"
Parser
(Maybe NodeIPv6Address -> [RootConfig] -> UseLedger -> NodeSetup)
-> Parser (Maybe NodeIPv6Address)
-> Parser ([RootConfig] -> UseLedger -> NodeSetup)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe NodeIPv6Address)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"nodeIPv6Address"
Parser ([RootConfig] -> UseLedger -> NodeSetup)
-> Parser [RootConfig] -> Parser (UseLedger -> NodeSetup)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser [RootConfig]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"producers"
Parser (UseLedger -> NodeSetup)
-> Parser UseLedger -> Parser NodeSetup
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe UseLedger)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"useLedgerAfterSlot" Parser (Maybe UseLedger) -> UseLedger -> Parser UseLedger
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" Key -> Word64 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NodeSetup -> Word64
nodeId NodeSetup
ns
, Key
"nodeIPv4Address" Key -> Maybe NodeIPv4Address -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NodeSetup -> Maybe NodeIPv4Address
nodeIPv4Address NodeSetup
ns
, Key
"nodeIPv6Address" Key -> Maybe NodeIPv6Address -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NodeSetup -> Maybe NodeIPv6Address
nodeIPv6Address NodeSetup
ns
, Key
"producers" Key -> [RootConfig] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= NodeSetup -> [RootConfig]
producers NodeSetup
ns
, Key
"useLedgerAfterSlot" Key -> UseLedger -> Pair
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
(RootConfig -> RootConfig -> Bool)
-> (RootConfig -> RootConfig -> Bool) -> Eq RootConfig
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
(Int -> RootConfig -> ShowS)
-> (RootConfig -> String)
-> ([RootConfig] -> ShowS)
-> Show RootConfig
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 = String
-> (Object -> Parser RootConfig) -> Value -> Parser RootConfig
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RootConfig" ((Object -> Parser RootConfig) -> Value -> Parser RootConfig)
-> (Object -> Parser RootConfig) -> Value -> Parser RootConfig
forall a b. (a -> b) -> a -> b
$ \Object
o ->
[RelayAccessPoint] -> PeerAdvertise -> RootConfig
RootConfig
([RelayAccessPoint] -> PeerAdvertise -> RootConfig)
-> Parser [RelayAccessPoint]
-> Parser (PeerAdvertise -> RootConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser [RelayAccessPoint]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"accessPoints"
Parser (PeerAdvertise -> RootConfig)
-> Parser PeerAdvertise -> Parser RootConfig
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe PeerAdvertise)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"advertise" Parser (Maybe PeerAdvertise)
-> PeerAdvertise -> Parser PeerAdvertise
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" Key -> [RelayAccessPoint] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= RootConfig -> [RelayAccessPoint]
rootAccessPoints RootConfig
ra
, Key
"advertise" Key -> PeerAdvertise -> Pair
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
(LocalRootPeersGroup -> LocalRootPeersGroup -> Bool)
-> (LocalRootPeersGroup -> LocalRootPeersGroup -> Bool)
-> Eq LocalRootPeersGroup
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
(Int -> LocalRootPeersGroup -> ShowS)
-> (LocalRootPeersGroup -> String)
-> ([LocalRootPeersGroup] -> ShowS)
-> Show LocalRootPeersGroup
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 = String
-> (Object -> Parser LocalRootPeersGroup)
-> Value
-> Parser LocalRootPeersGroup
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"LocalRootPeersGroup" ((Object -> Parser LocalRootPeersGroup)
-> Value -> Parser LocalRootPeersGroup)
-> (Object -> Parser LocalRootPeersGroup)
-> Value
-> Parser LocalRootPeersGroup
forall a b. (a -> b) -> a -> b
$ \Object
o ->
RootConfig -> Int -> LocalRootPeersGroup
LocalRootPeersGroup
(RootConfig -> Int -> LocalRootPeersGroup)
-> Parser RootConfig -> Parser (Int -> LocalRootPeersGroup)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser RootConfig
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"localRoots"
Parser (Int -> LocalRootPeersGroup)
-> Parser Int -> Parser LocalRootPeersGroup
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"valency"
instance ToJSON LocalRootPeersGroup where
toJSON :: LocalRootPeersGroup -> Value
toJSON LocalRootPeersGroup
lrpg =
[Pair] -> Value
object
[ Key
"localRoots" Key -> RootConfig -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LocalRootPeersGroup -> RootConfig
localRoots LocalRootPeersGroup
lrpg
, Key
"valency" Key -> Int -> Pair
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
(LocalRootPeersGroups -> LocalRootPeersGroups -> Bool)
-> (LocalRootPeersGroups -> LocalRootPeersGroups -> Bool)
-> Eq LocalRootPeersGroups
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
(Int -> LocalRootPeersGroups -> ShowS)
-> (LocalRootPeersGroups -> String)
-> ([LocalRootPeersGroups] -> ShowS)
-> Show LocalRootPeersGroups
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 = String
-> (Object -> Parser LocalRootPeersGroups)
-> Value
-> Parser LocalRootPeersGroups
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"LocalRootPeersGroups" ((Object -> Parser LocalRootPeersGroups)
-> Value -> Parser LocalRootPeersGroups)
-> (Object -> Parser LocalRootPeersGroups)
-> Value
-> Parser LocalRootPeersGroups
forall a b. (a -> b) -> a -> b
$ \Object
o ->
[LocalRootPeersGroup] -> LocalRootPeersGroups
LocalRootPeersGroups
([LocalRootPeersGroup] -> LocalRootPeersGroups)
-> Parser [LocalRootPeersGroup] -> Parser LocalRootPeersGroups
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser [LocalRootPeersGroup]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"groups"
instance ToJSON LocalRootPeersGroups where
toJSON :: LocalRootPeersGroups -> Value
toJSON LocalRootPeersGroups
lrpg =
[Pair] -> Value
object
[ Key
"groups" Key -> [LocalRootPeersGroup] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LocalRootPeersGroups -> [LocalRootPeersGroup]
groups LocalRootPeersGroups
lrpg
]
newtype PublicRootPeers = PublicRootPeers
{ PublicRootPeers -> RootConfig
publicRoots :: RootConfig
} deriving (PublicRootPeers -> PublicRootPeers -> Bool
(PublicRootPeers -> PublicRootPeers -> Bool)
-> (PublicRootPeers -> PublicRootPeers -> Bool)
-> Eq PublicRootPeers
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
(Int -> PublicRootPeers -> ShowS)
-> (PublicRootPeers -> String)
-> ([PublicRootPeers] -> ShowS)
-> Show PublicRootPeers
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 = String
-> (Object -> Parser PublicRootPeers)
-> Value
-> Parser PublicRootPeers
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"PublicRootPeers" ((Object -> Parser PublicRootPeers)
-> Value -> Parser PublicRootPeers)
-> (Object -> Parser PublicRootPeers)
-> Value
-> Parser PublicRootPeers
forall a b. (a -> b) -> a -> b
$ \Object
o ->
RootConfig -> PublicRootPeers
PublicRootPeers
(RootConfig -> PublicRootPeers)
-> Parser RootConfig -> Parser PublicRootPeers
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser RootConfig
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"publicRoots"
instance ToJSON PublicRootPeers where
toJSON :: PublicRootPeers -> Value
toJSON PublicRootPeers
prp =
[Pair] -> Value
object
[ Key
"publicRoots" Key -> RootConfig -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= PublicRootPeers -> RootConfig
publicRoots PublicRootPeers
prp
]
data NetworkTopology = RealNodeTopology !LocalRootPeersGroups ![PublicRootPeers] !UseLedger
deriving (NetworkTopology -> NetworkTopology -> Bool
(NetworkTopology -> NetworkTopology -> Bool)
-> (NetworkTopology -> NetworkTopology -> Bool)
-> Eq NetworkTopology
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
(Int -> NetworkTopology -> ShowS)
-> (NetworkTopology -> String)
-> ([NetworkTopology] -> ShowS)
-> Show NetworkTopology
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 = String
-> (Object -> Parser NetworkTopology)
-> Value
-> Parser NetworkTopology
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"NetworkTopology" ((Object -> Parser NetworkTopology)
-> Value -> Parser NetworkTopology)
-> (Object -> Parser NetworkTopology)
-> Value
-> Parser NetworkTopology
forall a b. (a -> b) -> a -> b
$ \Object
o ->
LocalRootPeersGroups
-> [PublicRootPeers] -> UseLedger -> NetworkTopology
RealNodeTopology (LocalRootPeersGroups
-> [PublicRootPeers] -> UseLedger -> NetworkTopology)
-> Parser LocalRootPeersGroups
-> Parser ([PublicRootPeers] -> UseLedger -> NetworkTopology)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> Key -> Parser LocalRootPeersGroups
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"LocalRoots" )
Parser ([PublicRootPeers] -> UseLedger -> NetworkTopology)
-> Parser [PublicRootPeers]
-> Parser (UseLedger -> NetworkTopology)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o Object -> Key -> Parser [PublicRootPeers]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"PublicRoots" )
Parser (UseLedger -> NetworkTopology)
-> Parser UseLedger -> Parser NetworkTopology
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Object
o Object -> Key -> Parser (Maybe UseLedger)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"useLedgerAfterSlot" Parser (Maybe UseLedger) -> UseLedger -> Parser UseLedger
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" Key -> LocalRootPeersGroups -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LocalRootPeersGroups
lrpg
, Key
"PublicRoots" Key -> [PublicRootPeers] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [PublicRootPeers]
prp
, Key
"useLedgerAfterSlot" Key -> UseLedger -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UseLedger
ul
]
readTopologyFile :: NodeConfiguration -> IO (Either Text NetworkTopology)
readTopologyFile :: NodeConfiguration -> IO (Either Text NetworkTopology)
readTopologyFile NodeConfiguration
nc = do
Either IOException ByteString
eBs <- IO ByteString -> IO (Either IOException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
Exception.try (IO ByteString -> IO (Either IOException ByteString))
-> IO ByteString -> IO (Either IOException ByteString)
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile (TopologyFile -> String
unTopology (TopologyFile -> String) -> TopologyFile -> String
forall a b. (a -> b) -> a -> b
$ NodeConfiguration -> TopologyFile
ncTopologyFile NodeConfiguration
nc)
case Either IOException ByteString
eBs of
Left IOException
e -> Either Text NetworkTopology -> IO (Either Text NetworkTopology)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text NetworkTopology -> IO (Either Text NetworkTopology))
-> (Text -> Either Text NetworkTopology)
-> Text
-> IO (Either Text NetworkTopology)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Either Text NetworkTopology
forall a b. a -> Either a b
Left (Text -> IO (Either Text NetworkTopology))
-> Text -> IO (Either Text NetworkTopology)
forall a b. (a -> b) -> a -> b
$ IOException -> Text
handler IOException
e
Right ByteString
bs -> Either Text NetworkTopology -> IO (Either Text NetworkTopology)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text NetworkTopology -> IO (Either Text NetworkTopology))
-> (ByteString -> Either Text NetworkTopology)
-> ByteString
-> IO (Either Text NetworkTopology)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (String -> Text)
-> Either String NetworkTopology -> Either Text NetworkTopology
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
handlerJSON (Either String NetworkTopology -> Either Text NetworkTopology)
-> (ByteString -> Either String NetworkTopology)
-> ByteString
-> Either Text NetworkTopology
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ByteString -> Either String NetworkTopology
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (ByteString -> IO (Either Text NetworkTopology))
-> ByteString -> IO (Either Text NetworkTopology)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict ByteString
bs
where
handler :: IOException -> Text
handler :: IOException -> Text
handler IOException
e = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Cardano.Node.Configuration.Topology.readTopologyFile: "
String -> ShowS
forall a. [a] -> [a] -> [a]
++ IOException -> String
forall e. Exception e => e -> String
displayException IOException
e
handlerJSON :: String -> Text
handlerJSON :: String -> Text
handlerJSON String
err = Text
"Is your topology file formatted correctly? \
\Expecting P2P Topology file format. \
\The port and valency fields should be numerical. \
\If you specified the correct topology file \
\make sure that you correctly setup EnableP2P \
\configuration flag. " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
err
readTopologyFileOrError :: NodeConfiguration -> IO NetworkTopology
readTopologyFileOrError :: NodeConfiguration -> IO NetworkTopology
readTopologyFileOrError NodeConfiguration
nc =
NodeConfiguration -> IO (Either Text NetworkTopology)
readTopologyFile NodeConfiguration
nc
IO (Either Text NetworkTopology)
-> (Either Text NetworkTopology -> IO NetworkTopology)
-> IO NetworkTopology
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> IO NetworkTopology)
-> (NetworkTopology -> IO NetworkTopology)
-> Either Text NetworkTopology
-> IO NetworkTopology
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\Text
err -> Text -> IO NetworkTopology
forall a. HasCallStack => Text -> a
panic (Text -> IO NetworkTopology) -> Text -> IO NetworkTopology
forall a b. (a -> b) -> a -> b
$ Text
"Cardano.Node.Run.handleSimpleNodeP2P.readTopologyFile: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
err)
NetworkTopology -> IO NetworkTopology
forall (f :: * -> *) a. Applicative f => a -> f a
pure