module Frenetic.Switches.OpenFlow
( prefixToIPAddressPrefix
, ipAddressPrefixToPrefix
, OpenFlow (..)
, toOFPkt
, fromOFPkt
, toOFPat
, fromOFPat
, toOFAct
, fromOFAct
, Nettle (..)
, actQueries
) where
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (catMaybes)
import Data.HList
import Control.Concurrent.Chan
import Data.Bits
import qualified Data.Set as Set
import qualified Data.MultiSet as MS
import Data.Word
import Data.List (nub, find)
import qualified Nettle.IPv4.IPAddress as IPAddr
import Nettle.Ethernet.AddressResolutionProtocol
import Frenetic.Pattern
import Frenetic.Compat
import Frenetic.NetCore.Types
import Control.Concurrent
import Frenetic.NettleEx hiding (AllPorts, ethernetAddress64)
import qualified Frenetic.NettleEx as NettleEx
ethToWord48 :: NettleEx.EthernetAddress
-> Frenetic.NetCore.Types.EthernetAddress
ethToWord48 = ethernetAddress64.unpack64
word48ToEth :: Frenetic.NetCore.Types.EthernetAddress
-> NettleEx.EthernetAddress
word48ToEth = NettleEx.ethernetAddress64 . unpackEth64
prefixToIPAddressPrefix :: Prefix Word32 -> IPAddressPrefix
prefixToIPAddressPrefix (Prefix x len) = (IPAddress x, fromIntegral len)
ipAddressPrefixToPrefix :: IPAddressPrefix -> Prefix Word32
ipAddressPrefixToPrefix (IPAddress x, len) = Prefix x (fromIntegral len)
instance Matchable IPAddressPrefix where
top = defaultIPPrefix
intersect = IPAddr.intersect
physicalPortOfPseudoPort (Physical p) = PhysicalPort p
physicalPortOfPseudoPort AllPorts = Flood
toController :: ActionSequence
toController = sendToController maxBound
instance Eq a => Matchable (Maybe a) where
top = Nothing
intersect (Just a) (Just b) = if a == b then Just (Just a) else Nothing
intersect (Just a) Nothing = Just (Just a)
intersect Nothing (Just b) = Just (Just b)
intersect Nothing Nothing = Just Nothing
wildcardToMaybe (Exact a) = Just a
wildcardToMaybe Wildcard = Nothing
maybeToWildcard (Just a) = Exact a
maybeToWildcard Nothing = Wildcard
instance Matchable Match where
top = Match {
inPort = Nothing,
srcEthAddress = top,
dstEthAddress = top,
vLANID = top,
vLANPriority = top,
ethFrameType = top,
ipTypeOfService = top,
matchIPProtocol = top,
srcIPAddress = top,
dstIPAddress = top,
srcTransportPort = top,
dstTransportPort = top }
intersect ofm1 ofm2 =
do inport <- intersect (inPort ofm1) (inPort ofm2)
srcethaddress <- intersect (srcEthAddress ofm1) (srcEthAddress ofm2)
dstethaddress <- intersect (dstEthAddress ofm1) (dstEthAddress ofm2)
vlanid <- intersect (vLANID ofm1) (vLANID ofm2)
vlanpriority <- intersect (vLANPriority ofm1) (vLANPriority ofm2)
ethframetype <- intersect (ethFrameType ofm1) (ethFrameType ofm2)
iptypeofservice <- intersect (ipTypeOfService ofm1) (ipTypeOfService ofm2)
ipprotocol <- intersect (matchIPProtocol ofm1) (matchIPProtocol ofm2)
srcipaddress <- intersect (srcIPAddress ofm1) (srcIPAddress ofm2)
dstipaddress <- intersect (dstIPAddress ofm1) (dstIPAddress ofm2)
srctransportport <- intersect (srcTransportPort ofm1) (srcTransportPort ofm2)
dsttransportport <- intersect (dstTransportPort ofm1) (dstTransportPort ofm2)
return Match {
inPort = inport,
srcEthAddress = srcethaddress,
dstEthAddress = dstethaddress,
vLANID = vlanid,
vLANPriority = vlanpriority,
ethFrameType = ethframetype,
ipTypeOfService = iptypeofservice,
matchIPProtocol = ipprotocol,
srcIPAddress = srcipaddress,
dstIPAddress = dstipaddress,
srcTransportPort = srctransportport,
dstTransportPort = dsttransportport }
nettleEthernetFrame pkt = case enclosedFrame pkt of
Left err -> Nothing
Right ef -> Just ef
nettleEthernetHeaders pkt = case enclosedFrame pkt of
Right (HCons hdr _) -> Just hdr
Left _ -> Nothing
nettleEthernetBody pkt = case enclosedFrame pkt of
Right (HCons _ (HCons body _)) -> Just body
Left _ -> Nothing
data OpenFlow = OpenFlow Nettle
instance Matchable (PatternImpl OpenFlow) where
top = OFPat top
intersect (OFPat p1) (OFPat p2) = case Frenetic.Pattern.intersect p1 p2 of
Just p3 -> Just (OFPat p3)
Nothing -> Nothing
toOFPkt :: PacketInfo -> PacketImpl OpenFlow
toOFPkt p = OFPkt p
fromOFPkt :: PacketImpl OpenFlow -> PacketInfo
fromOFPkt (OFPkt p) = p
toOFPat :: Match -> PatternImpl OpenFlow
toOFPat p = OFPat p
fromOFPat :: PatternImpl OpenFlow -> Match
fromOFPat (OFPat p) = p
toOFAct :: ActionSequence -> ActionImpl OpenFlow
toOFAct p = OFAct p []
instance Show (ActionImpl OpenFlow) where
show (OFAct acts ls) = show acts ++ " and " ++ show (length ls) ++ " queries"
ifNothing :: Maybe a -> a -> a
ifNothing (Just a) _ = a
ifNothing Nothing b = b
modTranslate :: Modification -> ActionSequence
modTranslate (Modification{..}) =
catMaybes [f1, f2, f3, f4, f5, f6, f7, f8, f9]
where f1 = case modifyDlSrc of
Nothing -> Nothing
Just v -> Just $ SetEthSrcAddr $ word48ToEth v
f2 = case modifyDlDst of
Nothing -> Nothing
Just v -> Just $ SetEthDstAddr $ word48ToEth v
f3 = case modifyDlVlan of
Nothing -> Nothing
Just (Just v) -> Just $ SetVlanVID v
Just Nothing -> Just StripVlanHeader
f4 = case modifyDlVlanPcp of
Nothing -> Nothing
Just v -> Just $ SetVlanPriority v
f5 = case modifyNwSrc of
Nothing -> Nothing
Just ip -> Just $ SetIPSrcAddr $ IPAddress ip
f6 = case modifyNwDst of
Nothing -> Nothing
Just ip -> Just $ SetIPDstAddr $ IPAddress ip
f7 = case modifyNwTos of
Nothing -> Nothing
Just v -> Just $ SetIPToS v
f8 = case modifyTpSrc of
Nothing -> Nothing
Just v -> Just $ SetTransportSrcPort v
f9 = case modifyTpDst of
Nothing -> Nothing
Just v -> Just $ SetTransportDstPort v
instance FreneticImpl OpenFlow where
data PacketImpl OpenFlow = OFPkt PacketInfo deriving (Show, Eq)
data PatternImpl OpenFlow = OFPat Match deriving (Show, Eq)
data ActionImpl OpenFlow = OFAct { fromOFAct :: ActionSequence,
actQueries :: [Query] }
deriving (Eq)
ptrnMatchPkt (OFPkt pkt) (OFPat ptrn) = case nettleEthernetFrame pkt of
Just frame -> matches (receivedOnPort pkt, frame) ptrn
Nothing -> False
toPacket (OFPkt pkt) = do
hdrs <- nettleEthernetHeaders pkt
body <- nettleEthernetBody pkt
proto <- ethProto body
tos <- ethTOS body
return $ Packet (ethToWord48 (sourceMACAddress hdrs))
(ethToWord48 (destMACAddress hdrs))
(typeCode hdrs)
(ethVLANId hdrs)
(ethVLANPcp hdrs)
(ethSrcIP body)
(ethDstIP body)
proto
tos
(srcPort body)
(dstPort body)
(receivedOnPort pkt)
fromPattern ptrn = OFPat Match {
srcEthAddress = wildcardToMaybe $ fmap word48ToEth (ptrnDlSrc ptrn),
dstEthAddress = wildcardToMaybe $ fmap word48ToEth (ptrnDlDst ptrn),
ethFrameType = wildcardToMaybe $ ptrnDlTyp ptrn,
vLANID = case ptrnDlVlan ptrn of
Exact (Just vl) -> Just vl
Exact Nothing -> Just $ fromInteger ofpVlanNone
Wildcard -> Nothing,
vLANPriority = wildcardToMaybe $ ptrnDlVlanPcp ptrn,
srcIPAddress = prefixToIPAddressPrefix (ptrnNwSrc ptrn),
dstIPAddress = prefixToIPAddressPrefix (ptrnNwDst ptrn),
matchIPProtocol = wildcardToMaybe $ ptrnNwProto ptrn,
ipTypeOfService = wildcardToMaybe $ ptrnNwTos ptrn,
srcTransportPort = wildcardToMaybe $ ptrnTpSrc ptrn,
dstTransportPort = wildcardToMaybe $ ptrnTpDst ptrn,
inPort = wildcardToMaybe $ ptrnInPort ptrn
}
toPattern (OFPat ptrn) = Pattern {
ptrnDlSrc = maybeToWildcard $ fmap ethToWord48 $ srcEthAddress ptrn,
ptrnDlDst = maybeToWildcard $ fmap ethToWord48 $ dstEthAddress ptrn,
ptrnDlTyp = maybeToWildcard $ ethFrameType ptrn,
ptrnDlVlan = case vLANID ptrn of
Just vl | vl == fromIntegral ofpVlanNone -> Exact Nothing
| otherwise -> Exact (Just vl)
Nothing -> Wildcard,
ptrnDlVlanPcp = maybeToWildcard $ vLANPriority ptrn,
ptrnNwSrc = ipAddressPrefixToPrefix $ srcIPAddress ptrn,
ptrnNwDst = ipAddressPrefixToPrefix $ dstIPAddress ptrn,
ptrnNwProto = maybeToWildcard $ matchIPProtocol ptrn,
ptrnNwTos = maybeToWildcard $ ipTypeOfService ptrn,
ptrnTpSrc = maybeToWildcard $ srcTransportPort ptrn,
ptrnTpDst = maybeToWildcard $ dstTransportPort ptrn,
ptrnInPort = maybeToWildcard $ inPort ptrn
}
actnController = OFAct toController []
actnDefault = OFAct toController []
actnTranslate act@(Action fwd queries) = OFAct (ofFwd ++ toCtrl) (MS.toList queries)
where acts = if hasUnimplementableMods $ map snd $ MS.toList fwd
then [SendOutPort (ToController maxBound)]
else ofFwd ++ toCtrl
ofFwd = concatMap (\(pp, md) -> modTranslate md
++ [SendOutPort (physicalPortOfPseudoPort pp)])
$ MS.toList fwd
toCtrl = case find isPktQuery (MS.toList queries) of
Just _ -> [SendOutPort (ToController maxBound)]
Nothing -> []
hasUnimplementableMods as
| length as <= 1 = False
| otherwise =
let minFields = foldl (\m p -> if Set.size p < Set.size m then p else m)
(modifiedFields $ head as)
(map modifiedFields $ tail as)
in not $ all (\pat -> Set.isSubsetOf (modifiedFields pat) minFields) as
actnControllerPart (OFAct _ queries) switchID ofPkt = do
let pktChans = map pktQueryChan . filter isPktQuery $ queries
let sendParsablePkt chan = case toPacket ofPkt of
Nothing -> return ()
Just pk -> writeChan chan (switchID, pk)
mapM_ sendParsablePkt pktChans