{-# 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 (..))


-- | 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
(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
      ]


-- | 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
(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
      ]

-- | 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
(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
                                             ]

-- | Read the `NetworkTopology` configuration from the specified file.
--
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