{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns        #-}

module Ouroboros.Network.Diffusion.Topology where

import Data.Map qualified as Map
import Data.Map.Strict (Map)

import Ouroboros.Network.Diffusion.Configuration (DiffusionMode)
import Ouroboros.Network.PeerSelection.LedgerPeers.Type (UseLedgerPeers)
import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise)
import Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint)
import Ouroboros.Network.PeerSelection.State.LocalRootPeers hiding (extraFlags)
import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LRP

data NetworkTopology extraConfig extraFlags =
  NetworkTopology {
    forall extraConfig extraFlags.
NetworkTopology extraConfig extraFlags
-> LocalRootPeersGroups extraFlags
localRootPeersGroups :: !(LocalRootPeersGroups extraFlags)
  , forall extraConfig extraFlags.
NetworkTopology extraConfig extraFlags -> [PublicRootPeers]
publicRootPeers      :: ![PublicRootPeers]
  , forall extraConfig extraFlags.
NetworkTopology extraConfig extraFlags -> UseLedgerPeers
useLedgerPeers       :: !UseLedgerPeers
  , forall extraConfig extraFlags.
NetworkTopology extraConfig extraFlags -> Maybe FilePath
peerSnapshotPath     :: !(Maybe FilePath)
  , forall extraConfig extraFlags.
NetworkTopology extraConfig extraFlags -> extraConfig
extraConfig          :: !extraConfig
  }
  deriving (NetworkTopology extraConfig extraFlags
-> NetworkTopology extraConfig extraFlags -> Bool
(NetworkTopology extraConfig extraFlags
 -> NetworkTopology extraConfig extraFlags -> Bool)
-> (NetworkTopology extraConfig extraFlags
    -> NetworkTopology extraConfig extraFlags -> Bool)
-> Eq (NetworkTopology extraConfig extraFlags)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall extraConfig extraFlags.
(Eq extraFlags, Eq extraConfig) =>
NetworkTopology extraConfig extraFlags
-> NetworkTopology extraConfig extraFlags -> Bool
$c== :: forall extraConfig extraFlags.
(Eq extraFlags, Eq extraConfig) =>
NetworkTopology extraConfig extraFlags
-> NetworkTopology extraConfig extraFlags -> Bool
== :: NetworkTopology extraConfig extraFlags
-> NetworkTopology extraConfig extraFlags -> Bool
$c/= :: forall extraConfig extraFlags.
(Eq extraFlags, Eq extraConfig) =>
NetworkTopology extraConfig extraFlags
-> NetworkTopology extraConfig extraFlags -> Bool
/= :: NetworkTopology extraConfig extraFlags
-> NetworkTopology extraConfig extraFlags -> Bool
Eq, Int -> NetworkTopology extraConfig extraFlags -> ShowS
[NetworkTopology extraConfig extraFlags] -> ShowS
NetworkTopology extraConfig extraFlags -> FilePath
(Int -> NetworkTopology extraConfig extraFlags -> ShowS)
-> (NetworkTopology extraConfig extraFlags -> FilePath)
-> ([NetworkTopology extraConfig extraFlags] -> ShowS)
-> Show (NetworkTopology extraConfig extraFlags)
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
forall extraConfig extraFlags.
(Show extraFlags, Show extraConfig) =>
Int -> NetworkTopology extraConfig extraFlags -> ShowS
forall extraConfig extraFlags.
(Show extraFlags, Show extraConfig) =>
[NetworkTopology extraConfig extraFlags] -> ShowS
forall extraConfig extraFlags.
(Show extraFlags, Show extraConfig) =>
NetworkTopology extraConfig extraFlags -> FilePath
$cshowsPrec :: forall extraConfig extraFlags.
(Show extraFlags, Show extraConfig) =>
Int -> NetworkTopology extraConfig extraFlags -> ShowS
showsPrec :: Int -> NetworkTopology extraConfig extraFlags -> ShowS
$cshow :: forall extraConfig extraFlags.
(Show extraFlags, Show extraConfig) =>
NetworkTopology extraConfig extraFlags -> FilePath
show :: NetworkTopology extraConfig extraFlags -> FilePath
$cshowList :: forall extraConfig extraFlags.
(Show extraFlags, Show extraConfig) =>
[NetworkTopology extraConfig extraFlags] -> ShowS
showList :: [NetworkTopology extraConfig extraFlags] -> ShowS
Show)

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

-- | A local root peers group.  Local roots are treated by the outbound
-- governor in a special way.  The node will make sure that a node has the
-- requested number ('valency'/'hotValency') of connections to the local root peer group.
-- 'warmValency' value is the value of warm/established connections that the node
-- will attempt to maintain. By default this value will be equal to 'hotValency'.
--
data LocalRootPeersGroup extraFlags = LocalRootPeersGroup
  { forall extraFlags. LocalRootPeersGroup extraFlags -> RootConfig
localRoots        :: RootConfig
  , forall extraFlags. LocalRootPeersGroup extraFlags -> HotValency
hotValency        :: HotValency
  , forall extraFlags. LocalRootPeersGroup extraFlags -> WarmValency
warmValency       :: WarmValency
  , forall extraFlags. LocalRootPeersGroup extraFlags -> DiffusionMode
rootDiffusionMode :: DiffusionMode
    -- ^ diffusion mode; used for local root peers.
  , forall extraFlags. LocalRootPeersGroup extraFlags -> extraFlags
extraFlags        :: extraFlags
  } deriving (LocalRootPeersGroup extraFlags
-> LocalRootPeersGroup extraFlags -> Bool
(LocalRootPeersGroup extraFlags
 -> LocalRootPeersGroup extraFlags -> Bool)
-> (LocalRootPeersGroup extraFlags
    -> LocalRootPeersGroup extraFlags -> Bool)
-> Eq (LocalRootPeersGroup extraFlags)
forall extraFlags.
Eq extraFlags =>
LocalRootPeersGroup extraFlags
-> LocalRootPeersGroup extraFlags -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall extraFlags.
Eq extraFlags =>
LocalRootPeersGroup extraFlags
-> LocalRootPeersGroup extraFlags -> Bool
== :: LocalRootPeersGroup extraFlags
-> LocalRootPeersGroup extraFlags -> Bool
$c/= :: forall extraFlags.
Eq extraFlags =>
LocalRootPeersGroup extraFlags
-> LocalRootPeersGroup extraFlags -> Bool
/= :: LocalRootPeersGroup extraFlags
-> LocalRootPeersGroup extraFlags -> Bool
Eq, Int -> LocalRootPeersGroup extraFlags -> ShowS
[LocalRootPeersGroup extraFlags] -> ShowS
LocalRootPeersGroup extraFlags -> FilePath
(Int -> LocalRootPeersGroup extraFlags -> ShowS)
-> (LocalRootPeersGroup extraFlags -> FilePath)
-> ([LocalRootPeersGroup extraFlags] -> ShowS)
-> Show (LocalRootPeersGroup extraFlags)
forall extraFlags.
Show extraFlags =>
Int -> LocalRootPeersGroup extraFlags -> ShowS
forall extraFlags.
Show extraFlags =>
[LocalRootPeersGroup extraFlags] -> ShowS
forall extraFlags.
Show extraFlags =>
LocalRootPeersGroup extraFlags -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall extraFlags.
Show extraFlags =>
Int -> LocalRootPeersGroup extraFlags -> ShowS
showsPrec :: Int -> LocalRootPeersGroup extraFlags -> ShowS
$cshow :: forall extraFlags.
Show extraFlags =>
LocalRootPeersGroup extraFlags -> FilePath
show :: LocalRootPeersGroup extraFlags -> FilePath
$cshowList :: forall extraFlags.
Show extraFlags =>
[LocalRootPeersGroup extraFlags] -> ShowS
showList :: [LocalRootPeersGroup extraFlags] -> ShowS
Show)

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
$c== :: PublicRootPeers -> PublicRootPeers -> Bool
== :: PublicRootPeers -> PublicRootPeers -> Bool
$c/= :: PublicRootPeers -> PublicRootPeers -> Bool
/= :: PublicRootPeers -> PublicRootPeers -> Bool
Eq, Int -> PublicRootPeers -> ShowS
[PublicRootPeers] -> ShowS
PublicRootPeers -> FilePath
(Int -> PublicRootPeers -> ShowS)
-> (PublicRootPeers -> FilePath)
-> ([PublicRootPeers] -> ShowS)
-> Show PublicRootPeers
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PublicRootPeers -> ShowS
showsPrec :: Int -> PublicRootPeers -> ShowS
$cshow :: PublicRootPeers -> FilePath
show :: PublicRootPeers -> FilePath
$cshowList :: [PublicRootPeers] -> ShowS
showList :: [PublicRootPeers] -> ShowS
Show)

-- | 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
    -- peer sharing.
  } deriving (RootConfig -> RootConfig -> Bool
(RootConfig -> RootConfig -> Bool)
-> (RootConfig -> RootConfig -> Bool) -> Eq RootConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RootConfig -> RootConfig -> Bool
== :: RootConfig -> RootConfig -> Bool
$c/= :: RootConfig -> RootConfig -> Bool
/= :: RootConfig -> RootConfig -> Bool
Eq, Int -> RootConfig -> ShowS
[RootConfig] -> ShowS
RootConfig -> FilePath
(Int -> RootConfig -> ShowS)
-> (RootConfig -> FilePath)
-> ([RootConfig] -> ShowS)
-> Show RootConfig
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RootConfig -> ShowS
showsPrec :: Int -> RootConfig -> ShowS
$cshow :: RootConfig -> FilePath
show :: RootConfig -> FilePath
$cshowList :: [RootConfig] -> ShowS
showList :: [RootConfig] -> ShowS
Show)


-- | 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 :: RootConfig -> [RelayAccessPoint]
rootAccessPoints :: [RelayAccessPoint]
rootAccessPoints, PeerAdvertise
rootAdvertise :: RootConfig -> PeerAdvertise
rootAdvertise :: PeerAdvertise
rootAdvertise  } =
    [ (RelayAccessPoint
ap, PeerAdvertise
rootAdvertise) | RelayAccessPoint
ap <- [RelayAccessPoint]
rootAccessPoints ]

producerAddresses
  :: NetworkTopology extraConfig extraFlags
  -> ( [(HotValency, WarmValency, Map RelayAccessPoint (LocalRootConfig extraFlags))]
     , Map RelayAccessPoint PeerAdvertise
     )
  -- ^ local roots & public roots
producerAddresses :: forall extraConfig extraFlags.
NetworkTopology extraConfig extraFlags
-> ([(HotValency, WarmValency,
      Map RelayAccessPoint (LocalRootConfig extraFlags))],
    Map RelayAccessPoint PeerAdvertise)
producerAddresses NetworkTopology { LocalRootPeersGroups extraFlags
localRootPeersGroups :: forall extraConfig extraFlags.
NetworkTopology extraConfig extraFlags
-> LocalRootPeersGroups extraFlags
localRootPeersGroups :: LocalRootPeersGroups extraFlags
localRootPeersGroups
                                  , [PublicRootPeers]
publicRootPeers :: forall extraConfig extraFlags.
NetworkTopology extraConfig extraFlags -> [PublicRootPeers]
publicRootPeers :: [PublicRootPeers]
publicRootPeers
                                  } =
  ( (LocalRootPeersGroup extraFlags
 -> (HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags)))
-> [LocalRootPeersGroup extraFlags]
-> [(HotValency, WarmValency,
     Map RelayAccessPoint (LocalRootConfig extraFlags))]
forall a b. (a -> b) -> [a] -> [b]
map (\LocalRootPeersGroup extraFlags
lrp -> ( LocalRootPeersGroup extraFlags -> HotValency
forall extraFlags. LocalRootPeersGroup extraFlags -> HotValency
hotValency LocalRootPeersGroup extraFlags
lrp
                 , LocalRootPeersGroup extraFlags -> WarmValency
forall extraFlags. LocalRootPeersGroup extraFlags -> WarmValency
warmValency LocalRootPeersGroup extraFlags
lrp
                 , [(RelayAccessPoint, LocalRootConfig extraFlags)]
-> Map RelayAccessPoint (LocalRootConfig extraFlags)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
                 ([(RelayAccessPoint, LocalRootConfig extraFlags)]
 -> Map RelayAccessPoint (LocalRootConfig extraFlags))
-> (RootConfig -> [(RelayAccessPoint, LocalRootConfig extraFlags)])
-> RootConfig
-> Map RelayAccessPoint (LocalRootConfig extraFlags)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((RelayAccessPoint, PeerAdvertise)
 -> (RelayAccessPoint, LocalRootConfig extraFlags))
-> [(RelayAccessPoint, PeerAdvertise)]
-> [(RelayAccessPoint, LocalRootConfig extraFlags)]
forall a b. (a -> b) -> [a] -> [b]
map (\(RelayAccessPoint
addr, PeerAdvertise
peerAdvertise) ->
                         ( RelayAccessPoint
addr
                         , LocalRootConfig {
                             diffusionMode :: DiffusionMode
diffusionMode = LocalRootPeersGroup extraFlags -> DiffusionMode
forall extraFlags. LocalRootPeersGroup extraFlags -> DiffusionMode
rootDiffusionMode LocalRootPeersGroup extraFlags
lrp,
                             PeerAdvertise
peerAdvertise :: PeerAdvertise
peerAdvertise :: PeerAdvertise
peerAdvertise,
                             extraFlags :: extraFlags
LRP.extraFlags = LocalRootPeersGroup extraFlags -> extraFlags
forall extraFlags. LocalRootPeersGroup extraFlags -> extraFlags
extraFlags LocalRootPeersGroup extraFlags
lrp
                           }
                         )
                       )
                 ([(RelayAccessPoint, PeerAdvertise)]
 -> [(RelayAccessPoint, LocalRootConfig extraFlags)])
-> (RootConfig -> [(RelayAccessPoint, PeerAdvertise)])
-> RootConfig
-> [(RelayAccessPoint, LocalRootConfig extraFlags)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RootConfig -> [(RelayAccessPoint, PeerAdvertise)]
rootConfigToRelayAccessPoint
                 (RootConfig -> Map RelayAccessPoint (LocalRootConfig extraFlags))
-> RootConfig -> Map RelayAccessPoint (LocalRootConfig extraFlags)
forall a b. (a -> b) -> a -> b
$ LocalRootPeersGroup extraFlags -> RootConfig
forall extraFlags. LocalRootPeersGroup extraFlags -> RootConfig
localRoots LocalRootPeersGroup extraFlags
lrp
                 )
        )
        (LocalRootPeersGroups extraFlags -> [LocalRootPeersGroup extraFlags]
forall extraFlags.
LocalRootPeersGroups extraFlags -> [LocalRootPeersGroup extraFlags]
groups LocalRootPeersGroups extraFlags
localRootPeersGroups)
  , (PublicRootPeers -> Map RelayAccessPoint PeerAdvertise)
-> [PublicRootPeers] -> Map RelayAccessPoint PeerAdvertise
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ( [(RelayAccessPoint, PeerAdvertise)]
-> Map RelayAccessPoint PeerAdvertise
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            ([(RelayAccessPoint, PeerAdvertise)]
 -> Map RelayAccessPoint PeerAdvertise)
-> (PublicRootPeers -> [(RelayAccessPoint, PeerAdvertise)])
-> PublicRootPeers
-> Map RelayAccessPoint PeerAdvertise
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RootConfig -> [(RelayAccessPoint, PeerAdvertise)]
rootConfigToRelayAccessPoint
            (RootConfig -> [(RelayAccessPoint, PeerAdvertise)])
-> (PublicRootPeers -> RootConfig)
-> PublicRootPeers
-> [(RelayAccessPoint, PeerAdvertise)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PublicRootPeers -> RootConfig
publicRoots
            ) [PublicRootPeers]
publicRootPeers
  )