module Frenetic.Topo
( Topo
, buildGraph
, getEdgeLabel
, getEdge
, reverseLoc
, subgraph
, isHost
, switches
, hosts
, lPorts
, ports
) where
import Data.Graph.Inductive.Graph
import Data.Graph.Inductive.Tree
import qualified Data.List as List
import qualified Data.Set as Set
import Frenetic.NetCore.Types
type Topo = Gr () Port
buildGraph :: [((Node, Port), (Node, Port))] -> Topo
buildGraph links = mkGraph nodes edges where
nodes = Set.toList .
Set.unions $
map (\ ((n1, _), (n2, _)) -> Set.fromList [(n1, ()), (n2, ())])
links
edges = Set.toList .
Set.unions $
map (\ ((n1, p1), (n2, p2)) ->
Set.fromList [(n1, n2, p1), (n2, n1, p2)])
links
filterGr :: (Graph gr) => (LNode a -> Bool) -> gr a b -> gr a b
filterGr pred gr = delNodes badNodes gr where
badNodes = map fst . filter (not . pred) . labNodes $ gr
subgraph :: (Graph gr) => Set.Set Node -> gr a b -> gr a b
subgraph nodes gr = filterGr (\(n, _) -> Set.member n nodes) gr
getEdgeLabel :: (Graph gr) => gr a b -> Node -> Node -> Maybe b
getEdgeLabel gr n1 n2 = lookup n2 (lsuc gr n1)
normal :: (Loc, Loc) -> (Loc, Loc)
normal (l1, l2) = if l1 < l2 then (l1, l2) else (l2, l1)
getEdge :: Topo -> Loc -> (Loc, Loc)
getEdge topo loc = normal (loc, reverseLoc topo loc)
reverseLoc :: Topo -> Loc -> Loc
reverseLoc topo loc@(Loc switch port) =
Loc (fromIntegral targetSwitch) targetPort
where
mTargetSwitch = List.find (\(_, port') -> port == port') $
lsuc topo (fromIntegral switch)
(targetSwitch, _) = case mTargetSwitch of
Just s -> s
Nothing ->
error ("Location invalid: could not find dest for "
++ show loc ++ " among "
++ show (labEdges topo))
mTargetPort = getEdgeLabel topo targetSwitch (fromIntegral switch)
targetPort = case mTargetPort of
Just p -> p
Nothing -> error ("Graph not undirected, inverse missing of: "
++ show loc)
switches :: (Graph gr) => gr a Port -> [Node]
switches topo = filter (not . isHost topo) $ nodes topo
hostPort :: Port
hostPort = 0
isHost :: (Graph gr) => gr a Port -> Node -> Bool
isHost topo node = elem hostPort (ports topo node)
hosts :: (Graph gr) => gr a Port -> [Node]
hosts topo = filter (isHost topo) $ nodes topo
lPorts :: (Graph gr) => gr a Port -> Node -> [(Node, Port)]
lPorts topo n = lsuc topo n
ports :: (Graph gr) => gr a Port -> Node -> [Port]
ports topo = map snd . lPorts topo