module Frenetic.Slices.Compile
(
transform
, transformEdge
, dynTransform
, compileSlice
, edgeCompileSlice
, modifyVlan
, setVlan
, matchesSwitch
) where
import Control.Monad
import Frenetic.Common
import qualified Data.Map as Map
import qualified Data.MultiSet as MS
import qualified Data.Set as Set
import Frenetic.NetCore.Types
import Frenetic.NetCore.Short
import Frenetic.Pattern
import Frenetic.NetCore.Reduce
import Frenetic.NetCore.Pretty
import Frenetic.Slices.Slice
import Frenetic.Slices.VlanAssignment
import Frenetic.Topo
vlanMatch :: Vlan -> Predicate
vlanMatch vlan = dlVlan vlan
dynTransform :: [(Slice, Chan Policy)] -> IO (Chan Policy)
dynTransform combined = do
updateChan <- newChan :: IO (Chan (Vlan, Policy))
outputChan <- newChan :: IO (Chan Policy)
let tagged = zip [1..] combined
let poll (vlan, (slice, policyChan)) = do
let loop = do
update <- readChan policyChan
let compiled = compileSlice slice vlan update
writeChan updateChan (vlan, compiled)
forkIO $ forever $ loop
mapM_ poll tagged
let loop map = do
(vlan, compiled) <- readChan updateChan
let map' = Map.insert vlan compiled map
writeChan outputChan $ mconcat (Map.elems map')
loop map'
forkIO $ loop Map.empty
return outputChan
transform :: [(Slice, Policy)] -> Policy
transform combined = mconcat policies
where
tagged = sequential combined
policies = map (\(vlan, (slice, policy)) -> compileSlice slice vlan policy)
tagged
transformEdge :: Topo -> [(Slice, Policy)] -> Policy
transformEdge topo combined = mconcat policies where
tagged = edge topo combined
policies = map (\(assignment, (slice, policy)) ->
edgeCompileSlice slice assignment policy)
tagged
compileSlice :: Slice -> Vlan -> Policy -> Policy
compileSlice slice vlan policy =
if poUsesVlans policy then error "input policy uses VLANs." else
let localPolicy = localize slice policy in
let safePolicy = isolate slice vlan localPolicy in
let inportPolicy = inportPo slice vlan localPolicy in
let safeInportPolicy = PoUnion safePolicy inportPolicy in
reduce $ outport slice safeInportPolicy
edgeCompileSlice :: Slice -> Map.Map Loc Vlan -> Policy -> Policy
edgeCompileSlice slice assignment policy = mconcat (queryPols : forwardPols)
where
localPolicy = localize slice policy
queryPols = queryOnly slice assignment localPolicy
forwardPols = forwardEdges slice assignment localPolicy
queryOnly :: Slice -> Map.Map Loc Vlan -> Policy -> Policy
queryOnly slice assignment policy = justQueries <%> (onSlice <||> inBound) where
onSlice = prOr . map onPort . Set.toList $ internal slice
inBound = ingressPredicate slice <&&> dlNoVlan
justQueries = removeForwards policy
onPort l@(Loc s p) = inport s p <&&> dlVlan vlan <&&>
Map.findWithDefault top l (ingress slice) where
vlan = case Map.lookup l assignment of
Just v -> v
Nothing -> error $
"assignment map incomplete at " ++ show l ++
"\nmap: " ++ show assignment ++
"\nslice: " ++ show (internal slice)
removeForwards :: Policy -> Policy
removeForwards PoBottom = PoBottom
removeForwards (PoBasic pred (Action _ qs)) = PoBasic pred (Action MS.empty qs)
removeForwards (PoUnion p1 p2) = PoUnion p1' p2' where
p1' = removeForwards p1
p2' = removeForwards p2
removeQueries :: Policy -> Policy
removeQueries PoBottom = PoBottom
removeQueries (PoBasic pred (Action fs _)) = PoBasic pred (Action fs MS.empty)
removeQueries (PoUnion p1 p2) = PoUnion p1' p2' where
p1' = removeQueries p1
p2' = removeQueries p2
justTo :: Port -> Policy -> Policy
justTo _ PoBottom = PoBottom
justTo p (PoBasic pred (Action fs qs)) = PoBasic pred (Action fs' qs) where
fs' = MS.filter matches fs
matches (Physical p', _) = p == p'
matches (AllPorts, _) = error "AllPorts found while compiling."
justTo p (PoUnion p1 p2) = PoUnion p1' p2' where
p1' = justTo p p1
p2' = justTo p p2
forwardEdges :: Slice -> Map.Map Loc Vlan -> Policy -> [Policy]
forwardEdges slice assignment policy = concatMap buildPort locs where
int = internal slice
ing = Map.keysSet (ingress slice)
egr = Map.keysSet (egress slice)
portLookup = portsOfSet (Set.union int (Set.union ing egr))
locs = Set.toList (Set.union int ing)
buildPort :: Loc -> [Policy]
buildPort l@(Loc s p) = map hop $ Set.toList destinations where
destinations = case Map.lookup s portLookup of
Just dests -> dests
Nothing -> error "Port lookup malformed."
ourVlan = if Set.member l ing then dlNoVlan
else case Map.lookup l assignment of
Just v -> dlVlan v
Nothing -> error "Vlan assignment malformed."
restriction = inport s p <&&>
ourVlan <&&>
Map.findWithDefault top l (ingress slice)
policy' = policy <%> restriction
hop :: Port -> Policy
hop port = policy''' where
loc = Loc s port
targetVlan = if Set.member loc egr then Nothing
else case Map.lookup loc assignment of
Just v -> Just v
Nothing -> error "Vlan assignment malformed."
policy'' = justTo port policy'
policy''' = modifyVlan targetVlan policy''
portsOfSet :: Set.Set Loc -> Map.Map Switch (Set.Set Port)
portsOfSet = Map.fromListWith Set.union .
map (\(Loc s p) -> (s, Set.singleton p)) .
Set.toList
isolate :: Slice -> Vlan -> Policy -> Policy
isolate slice vlan policy = policy <%> (vlPred <&&> intern)
where
vlPred = vlanMatch vlan
intern = prOr . map (\(Loc s p) -> inport s p) . Set.toList $
internal slice
locToPred :: Loc -> Predicate
locToPred (Loc switch port) = inport switch port
inportPo :: Slice -> Vlan -> Policy -> Policy
inportPo slice vlan policy =
let incoming = ingressPredicate slice in
let policyIntoVlan = modifyVlan (Just vlan) policy in
policyIntoVlan <%> (incoming <&&> dlNoVlan)
outport :: Slice -> Policy -> Policy
outport slice policy = foldr stripVlan policy locs
where locs = Map.keys (egress slice)
ingressPredicate :: Slice -> Predicate
ingressPredicate slice =
prOr . map ingressSpecToPred . Map.assocs $ ingress slice
ingressSpecToPred :: (Loc, Predicate) -> Predicate
ingressSpecToPred (loc, pred) = PrIntersect pred (locToPred loc)
modifyVlan :: Maybe Vlan -> Policy -> Policy
modifyVlan _ PoBottom = PoBottom
modifyVlan vlan (PoBasic pred (Action m obs)) = PoBasic pred (Action m' obs)
where
m' = MS.map setVlans m
setVlans (p, mod) = (p, mod {modifyDlVlan = Just vlan})
modifyVlan vlan (PoUnion p1 p2) = PoUnion (modifyVlan vlan p1)
(modifyVlan vlan p2)
stripVlan :: Loc -> Policy -> Policy
stripVlan = setVlan Nothing
setVlan :: Maybe Vlan -> Loc -> Policy -> Policy
setVlan _ _ PoBottom = PoBottom
setVlan vlan loc (PoUnion p1 p2) = PoUnion (setVlan vlan loc p1)
(setVlan vlan loc p2)
setVlan vlan (Loc switch port) pol@(PoBasic pred (Action m obs)) =
if matchesSwitch switch pred then PoBasic pred (Action m' obs)
else pol
where
m' = MS.map setVlanOnPort m
setVlanOnPort (Physical p, mod) =
if p == port then (Physical p, mod {modifyDlVlan = Just vlan})
else (Physical p, mod)
setVlanOnPort (AllPorts, mod) =
error "AllPorts encountered in slice compilation. Did you first localize?"
matchesSwitch :: Switch -> Predicate -> Bool
matchesSwitch _ (PrPattern _) = True
matchesSwitch s1 (PrTo s2) = s1 == s2
matchesSwitch s (PrUnion p1 p2) = matchesSwitch s p1 || matchesSwitch s p2
matchesSwitch s (PrIntersect p1 p2) = matchesSwitch s p1 && matchesSwitch s p2
matchesSwitch s (PrNegate _) = True