{-# LANGUAGE CPP, DisambiguateRecordFields, RecordWildCards, NamedFieldPuns #-} -- | This module implements parsing and unparsing functions for -- OpenFlow messages. It exports a driver that can be used to read messages -- from a file handle and write messages to a handle. module Nettle.OpenFlow.MessagesBinary ( -- * Driver and Server messageDriver , openFlowServer -- * Parsing and unparsing methods , getSCMessage , putCSMessage ) where import Nettle.Ethernet.EthernetAddress import Nettle.Ethernet.EthernetFrame import Nettle.IPv4.IPAddress import Nettle.IPv4.IPPacket import qualified Nettle.OpenFlow.Messages as M import Nettle.OpenFlow.Port import Nettle.OpenFlow.Action import Nettle.OpenFlow.Switch import Nettle.OpenFlow.Match import Nettle.OpenFlow.Packet import Nettle.OpenFlow.FlowTable import qualified Nettle.OpenFlow.FlowTable as FlowTable import Nettle.OpenFlow.Statistics import Nettle.OpenFlow.Error import Nettle.Servers.TCPServer import Nettle.Servers.MultiplexedTCPServer import Control.Monad (when) import Control.Exception import Data.Word import Data.Bits import Data.Binary import Data.Binary.Put import Data.Binary.Get import qualified Data.ByteString.Lazy as B import Data.Maybe (fromJust, isJust) import Data.List as List import Data.Char (chr) import Data.Map (Map) import qualified Data.Map as Map import Data.Bimap (Bimap, (!)) import qualified Data.Bimap as Bimap -- | @openFlowServer portNum@ starts a TCP server listening for new connections at @portNum@ and -- returns a process that can be used to receive OpenFlow events and send OpenFlow messages. openFlowServer :: ServerPortNumber -- ^ TCP port at which the server will listen for connections. -> IO (Process (TCPMessage (M.TransactionID, M.SCMessage)) (SockAddr, (M.TransactionID, M.CSMessage)) IOException) -- ^ A process providing a method to read @SCMessage@s from switches, a method write @CSMessage@s to switches, and terminates with an @IOException@. openFlowServer pnum = muxedTCPServer pnum messageDriver -- | A message driver for use with TCP servers. messageDriver :: TCPMessageDriver (M.TransactionID, M.SCMessage) (M.TransactionID, M.CSMessage) messageDriver = TCPMessageDriver g p where g hdl = do hdrBS <- B.hGet hdl headerSize let bytesRead = B.length hdrBS if (bytesRead == 0) then return Nothing else do when (bytesRead /= fromIntegral headerSize) (tooFewBytesReadError headerSize bytesRead) let hdr = runGet getHeader hdrBS sanityCheck hdr let expectedLenOfBody = fromIntegral (msgLength hdr) - bytesRead bodyBS <- B.hGet hdl (fromIntegral expectedLenOfBody) let bytesRead' = B.length bodyBS when (bytesRead' /= expectedLenOfBody) (tooFewBytesReadError expectedLenOfBody bytesRead') return (Just (runGet (getSCMessageBody hdr) bodyBS)) tooFewBytesReadError expected actual = let msg = "Expected to read " ++ show expected ++ " bytes, but only read " ++ show actual ++ "bytes." in ioError $ userError $ msg p msg hdl = B.hPut hdl (runPut (putCSMessage msg)) sanityCheck :: OFPHeader -> IO () sanityCheck hdr = do when (msgVersion hdr /= ofpVersion) (ioError $ userError ("Bytes read from socket do not have the expected version (" ++ show ofpVersion ++ "). Header was: " ++ show hdr)) when (not $ validMessageType $ msgType hdr) (ioError $ userError ("Bytes read from socket do not have a valid message type. Header was: " ++ show hdr)) type MessageTypeCode = Word8 #if OPENFLOW_VERSION==151 ofptHello :: MessageTypeCode ofptHello = 0 ofptError :: MessageTypeCode ofptError = 1 ofptEchoRequest :: MessageTypeCode ofptEchoRequest = 2 ofptEchoReply :: MessageTypeCode ofptEchoReply = 3 ofptVendor :: MessageTypeCode ofptVendor = 4 ofptFeaturesRequest :: MessageTypeCode ofptFeaturesRequest = 5 ofptFeaturesReply :: MessageTypeCode ofptFeaturesReply = 6 ofptGetConfigRequest :: MessageTypeCode ofptGetConfigRequest = 7 ofptGetConfigReply :: MessageTypeCode ofptGetConfigReply = 8 ofptSetConfig :: MessageTypeCode ofptSetConfig = 9 ofptPacketIn :: MessageTypeCode ofptPacketIn = 10 ofptFlowExpired :: MessageTypeCode ofptFlowExpired = 11 ofptPortStatus :: MessageTypeCode ofptPortStatus = 12 ofptPacketOut :: MessageTypeCode ofptPacketOut = 13 ofptFlowMod :: MessageTypeCode ofptFlowMod = 14 ofptPortMod :: MessageTypeCode ofptPortMod = 15 ofptStatsRequest :: MessageTypeCode ofptStatsRequest = 16 ofptStatsReply :: MessageTypeCode ofptStatsReply = 17 validMessageTypes = [ofptHello, ofptError, ofptEchoRequest, ofptEchoReply, ofptFeaturesReply, ofptPacketIn, ofptFlowExpired, ofptStatsReply, ofptPortStatus] #endif #if OPENFLOW_VERSION==152 ofptHello :: MessageTypeCode ofptHello = 0 ofptError :: MessageTypeCode ofptError = 1 ofptEchoRequest :: MessageTypeCode ofptEchoRequest = 2 ofptEchoReply :: MessageTypeCode ofptEchoReply = 3 ofptVendor :: MessageTypeCode ofptVendor = 4 ofptFeaturesRequest :: MessageTypeCode ofptFeaturesRequest = 5 ofptFeaturesReply :: MessageTypeCode ofptFeaturesReply = 6 ofptGetConfigRequest :: MessageTypeCode ofptGetConfigRequest = 7 ofptGetConfigReply :: MessageTypeCode ofptGetConfigReply = 8 ofptSetConfig :: MessageTypeCode ofptSetConfig = 9 ofptPacketIn :: MessageTypeCode ofptPacketIn = 10 ofptFlowRemoved :: MessageTypeCode ofptFlowRemoved = 11 ofptPortStatus :: MessageTypeCode ofptPortStatus = 12 ofptPacketOut :: MessageTypeCode ofptPacketOut = 13 ofptFlowMod :: MessageTypeCode ofptFlowMod = 14 ofptPortMod :: MessageTypeCode ofptPortMod = 15 ofptStatsRequest :: MessageTypeCode ofptStatsRequest = 16 ofptStatsReply :: MessageTypeCode ofptStatsReply = 17 ofptBarrierRequest :: MessageTypeCode ofptBarrierRequest = 18 ofptBarrierReply :: MessageTypeCode ofptBarrierReply = 19 validMessageTypes = [ofptHello, ofptError, ofptEchoRequest, ofptEchoReply, ofptFeaturesReply, ofptPacketIn, ofptFlowRemoved, ofptBarrierReply, ofptStatsReply, ofptPortStatus] #endif #if OPENFLOW_VERSION==1 ofptHello :: MessageTypeCode ofptHello = 0 ofptError :: MessageTypeCode ofptError = 1 ofptEchoRequest :: MessageTypeCode ofptEchoRequest = 2 ofptEchoReply :: MessageTypeCode ofptEchoReply = 3 ofptVendor :: MessageTypeCode ofptVendor = 4 ofptFeaturesRequest :: MessageTypeCode ofptFeaturesRequest = 5 ofptFeaturesReply :: MessageTypeCode ofptFeaturesReply = 6 ofptGetConfigRequest :: MessageTypeCode ofptGetConfigRequest = 7 ofptGetConfigReply :: MessageTypeCode ofptGetConfigReply = 8 ofptSetConfig :: MessageTypeCode ofptSetConfig = 9 ofptPacketIn :: MessageTypeCode ofptPacketIn = 10 ofptFlowRemoved :: MessageTypeCode ofptFlowRemoved = 11 ofptPortStatus :: MessageTypeCode ofptPortStatus = 12 ofptPacketOut :: MessageTypeCode ofptPacketOut = 13 ofptFlowMod :: MessageTypeCode ofptFlowMod = 14 ofptPortMod :: MessageTypeCode ofptPortMod = 15 ofptStatsRequest :: MessageTypeCode ofptStatsRequest = 16 ofptStatsReply :: MessageTypeCode ofptStatsReply = 17 ofptBarrierRequest :: MessageTypeCode ofptBarrierRequest = 18 ofptBarrierReply :: MessageTypeCode ofptBarrierReply = 19 ofptQueueGetConfigRequest :: MessageTypeCode ofptQueueGetConfigRequest = 20 ofptQueueGetConfigReply :: MessageTypeCode ofptQueueGetConfigReply = 21 validMessageTypes = [ofptHello, ofptError, ofptEchoRequest, ofptEchoReply, ofptFeaturesReply, ofptPacketIn, ofptFlowRemoved, ofptBarrierReply, ofptStatsReply, ofptPortStatus] #endif validMessageType tcode = elem tcode validMessageTypes -- | Parser for @SCMessage@s getSCMessage :: Get (M.TransactionID, M.SCMessage) getSCMessage = do hdr <- getHeader getSCMessageBody hdr {- Header -} type OpenFlowVersionID = Word8 ofpVersion :: OpenFlowVersionID #if OPENFLOW_VERSION == 1 ofpVersion = 0x01 #endif #if OPENFLOW_VERSION == 152 ofpVersion = 0x98 #endif #if OPENFLOW_VERSION == 151 ofpVersion = 0x97 #endif -- | OpenFlow message header data OFPHeader = OFPHeader { msgVersion :: OpenFlowVersionID , msgType :: MessageTypeCode , msgLength :: Word16 , msgTransactionID :: M.TransactionID } deriving (Show,Eq) headerSize :: Int headerSize = 8 -- | Unparser for OpenFlow message header putHeader :: OFPHeader -> Put putHeader (OFPHeader {..}) = do putWord8 msgVersion putWord8 msgType putWord16be msgLength putWord32be msgTransactionID -- | Parser for the OpenFlow message header getHeader :: Get OFPHeader getHeader = do v <- getWord8 t <- getWord8 l <- getWord16be x <- getWord32be return $ OFPHeader v t l x -- Get SCMessage body getSCMessageBody :: OFPHeader -> Get (M.TransactionID, M.SCMessage) getSCMessageBody (OFPHeader {..}) = if msgType == ofptHello then return (msgTransactionID, M.SCHello) else if msgType == ofptEchoRequest then do bytes <- getWord8s (len - headerSize) return (msgTransactionID, M.SCEchoRequest bytes) else if msgType == ofptEchoReply then do bytes <- getWord8s (len - headerSize) return (msgTransactionID, M.SCEchoReply bytes) else if msgType == ofptFeaturesReply then do switchFeaturesRecord <- getSwitchFeaturesRecord len return (msgTransactionID, M.Features switchFeaturesRecord) else if msgType == ofptPacketIn then do packetInRecord <- getPacketInRecord len return (msgTransactionID, M.PacketIn packetInRecord) else if msgType == ofptPortStatus then do body <- getPortStatus return (msgTransactionID, M.PortStatus body) else if msgType == ofptError then do body <- getSwitchError len return (msgTransactionID, M.Error body) #if OPENFLOW_VERSION==151 else if msgType == ofptFlowExpired then do body <- getFlowRemovedRecord return (msgTransactionID, M.FlowRemoved body) #endif #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 else if msgType == ofptFlowRemoved then do body <- getFlowRemovedRecord return (msgTransactionID, M.FlowRemoved body) else if msgType == ofptBarrierReply then return (msgTransactionID, M.BarrierReply) #endif else if msgType == ofptStatsReply then do body <- getStatsReply len return (msgTransactionID, M.StatsReply body) else error "undefined" where len = fromIntegral msgLength ------------------------------------------- -- SWITCH FEATURES PARSER ------------------------------------------- getSwitchFeaturesRecord len = do dpid <- getWord64be nbufs <- getWord32be ntables <- getWord8 skip 3 caps <- getWord32be acts <- getWord32be ports <- sequence (replicate num_ports getPhyPort) return (SwitchFeatures dpid (fromIntegral nbufs) (fromIntegral ntables) (bitMap2SwitchCapabilitySet caps) (bitMap2SwitchActionSet acts) ports) where ports_offset = 32 num_ports = (len - ports_offset) `div` size_ofp_phy_port size_ofp_phy_port = 48 getPhyPort :: Get Port getPhyPort = do port_no <- get hw_addr <- getEthernetAddress name_arr <- getWord8s ofpMaxPortNameLen let port_name = [ chr (fromIntegral b) | b <- takeWhile (/=0) name_arr ] cfg <- getWord32be st <- getWord32be let (linkDown, stpState) = code2PortState st curr <- getWord32be adv <- getWord32be supp <- getWord32be peer <- getWord32be return $ Port { portID = port_no, portName = port_name, portAddress = hw_addr, portConfig = bitMap2PortConfigAttributeSet cfg, portLinkDown = linkDown, portSTPState = stpState, portCurrentFeatures = decodePortFeatureSet curr, portAdvertisedFeatures = decodePortFeatureSet adv, portSupportedFeatures = decodePortFeatureSet supp, portPeerFeatures = decodePortFeatureSet peer } where ofpMaxPortNameLen = 16 decodePortFeatureSet :: Word32 -> Maybe [PortFeature] decodePortFeatureSet word | word == 0 = Nothing | otherwise = Just $ concat [ if word `testBit` position then [feat] else [] | (feat, position) <- featurePositions ] where featurePositions = [ (Rate10MbHD, 0), (Rate10MbFD, 1), (Rate100MbHD, 2), (Rate100MbFD, 3), (Rate1GbHD, 4), (Rate1GbFD, 5), (Rate10GbFD, 6), (Copper, 7), (Fiber, 8), (AutoNegotiation, 9), (Pause, 10), (AsymmetricPause, 11) ] ofppsLinkDown, ofppsStpListen, ofppsStpLearn, ofppsStpForward :: Word32 ofppsLinkDown = 1 `shiftL` 0 -- 1 << 0 ofppsStpListen = 0 `shiftL` 8 -- 0 << 8 ofppsStpLearn = 1 `shiftL` 8 -- 1 << 8 ofppsStpForward = 2 `shiftL` 8 -- 2 << 8 ofppsStpBlock = 3 `shiftL` 8 -- 3 << 8 ofppsStpMask = 3 `shiftL` 8 -- 3 << 8 code2PortState :: Word32 -> (Bool, SpanningTreePortState) code2PortState w = (w .&. ofppsLinkDown /= 0, stpState) where stpState | flag == ofppsStpListen = STPListening | flag == ofppsStpLearn = STPLearning | flag == ofppsStpForward = STPForwarding | flag == ofppsStpBlock = STPBlocking | otherwise = error "Unrecognized port status code." flag = w .&. ofppsStpMask bitMap2PortConfigAttributeSet :: Word32 -> [PortConfigAttribute] bitMap2PortConfigAttributeSet bmap = filter inBMap $ enumFrom $ toEnum 0 where inBMap attr = let mask = portAttribute2BitMask attr in mask .&. bmap == mask portAttribute2BitMask :: PortConfigAttribute -> Word32 portAttribute2BitMask PortDown = shiftL 1 0 portAttribute2BitMask STPDisabled = shiftL 1 1 portAttribute2BitMask OnlySTPackets = shiftL 1 2 portAttribute2BitMask NoSTPackets = shiftL 1 3 portAttribute2BitMask NoFlooding = shiftL 1 4 portAttribute2BitMask DropForwarded = shiftL 1 5 portAttribute2BitMask NoPacketInMsg = shiftL 1 6 portAttributeSet2BitMask :: [PortConfigAttribute] -> Word32 portAttributeSet2BitMask = foldl f 0 where f mask b = mask .|. portAttribute2BitMask b bitMap2SwitchCapabilitySet :: Word32 -> [SwitchCapability] bitMap2SwitchCapabilitySet bmap = filter inBMap $ enumFrom $ toEnum 0 where inBMap attr = let mask = switchCapability2BitMask attr in mask .&. bmap == mask switchCapability2BitMask :: SwitchCapability -> Word32 switchCapability2BitMask HasFlowStats = shiftL 1 0 switchCapability2BitMask HasTableStats = shiftL 1 1 switchCapability2BitMask HasPortStats = shiftL 1 2 switchCapability2BitMask SpanningTree = shiftL 1 3 #if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152 switchCapability2BitMask MayTransmitOverMultiplePhysicalInterfaces = shiftL 1 4 #endif switchCapability2BitMask CanReassembleIPFragments = shiftL 1 5 #if OPENFLOW_VERSION==1 switchCapability2BitMask HasQueueStatistics = shiftL 1 6 switchCapability2BitMask CanMatchIPAddressesInARPPackets = shiftL 1 7 #endif bitMap2SwitchActionSet :: Word32 -> [ActionType] bitMap2SwitchActionSet bmap = filter inBMap $ enumFrom $ toEnum 0 where inBMap attr = let mask = actionType2BitMask attr in mask .&. bmap == mask code2ActionType :: Word16 -> ActionType code2ActionType code = case Bimap.lookupR code $ actionType2CodeBijection of Just x -> x Nothing -> error ("In code2ActionType: encountered unknown action type code: " ++ show code) actionType2Code :: ActionType -> Word16 actionType2Code a = case Bimap.lookup a actionType2CodeBijection of Just x -> x Nothing -> error ("In actionType2Code: encountered unknown action type: " ++ show a) #if OPENFLOW_VERSION==151 actionType2CodeBijection :: Bimap ActionType Word16 actionType2CodeBijection = Bimap.fromList [(OutputToPortType, 0) , (SetVlanVIDType, 1) , (SetVlanPriorityType, 2) , (StripVlanHeaderType, 3) , (SetEthSrcAddrType, 4) , (SetEthDstAddrType, 5) , (SetIPSrcAddrType, 6) , (SetIPDstAddrType, 7) , (SetTransportSrcPortType, 8) , (SetTransportDstPortType, 9) , (VendorActionType, 0xffff) ] #endif #if OPENFLOW_VERSION==152 actionType2CodeBijection :: Bimap ActionType Word16 actionType2CodeBijection = Bimap.fromList [(OutputToPortType, 0) , (SetVlanVIDType, 1) , (SetVlanPriorityType, 2) , (StripVlanHeaderType, 3) , (SetEthSrcAddrType, 4) , (SetEthDstAddrType, 5) , (SetIPSrcAddrType, 6) , (SetIPDstAddrType, 7) , (SetIPTypeOfServiceType, 8) , (SetTransportSrcPortType, 9) , (SetTransportDstPortType, 10) , (VendorActionType, 0xffff) ] #endif #if OPENFLOW_VERSION==1 actionType2CodeBijection :: Bimap ActionType Word16 actionType2CodeBijection = Bimap.fromList [(OutputToPortType, 0) , (SetVlanVIDType, 1) , (SetVlanPriorityType, 2) , (StripVlanHeaderType, 3) , (SetEthSrcAddrType, 4) , (SetEthDstAddrType, 5) , (SetIPSrcAddrType, 6) , (SetIPDstAddrType, 7) , (SetIPTypeOfServiceType, 8) , (SetTransportSrcPortType, 9) , (SetTransportDstPortType, 10) , (EnqueueType, 11) , (VendorActionType, 0xffff) ] #endif actionType2BitMask :: ActionType -> Word32 actionType2BitMask = shiftL 1 . fromIntegral . actionType2Code ------------------------------------------ -- Packet In Parser ------------------------------------------ getPacketInRecord :: Int -> Get PacketInfo getPacketInRecord len = do bufID <- getWord32be totalLen <- getWord16be in_port <- getWord16be reasonCode <- getWord8 skip 1 bytes <- getLazyByteString (fromIntegral data_len) let reason = code2Reason reasonCode let mbufID = if (bufID == maxBound) then Nothing else Just bufID return $ PacketInfo mbufID (fromIntegral totalLen) in_port reason bytes where data_offset = 8 + 4 + 2 + 2 + 1 + 1 data_len = len - data_offset code2Reason code | code == 0 = NotMatched | code == 1 = ExplicitSend | otherwise = error ("Received unknown packet-in reason code: " ++ show code ++ ".") ------------------------------------------ -- Port Status parser ------------------------------------------ getPortStatus :: Get PortStatus getPortStatus = do reasonCode <- getWord8 skip 7 portDesc <- getPhyPort return $ (code2PortStatusUpdateReason reasonCode, portDesc) code2PortStatusUpdateReason code = if code == 0 then PortAdded else if code == 1 then PortDeleted else if code == 2 then PortModified else error ("Unkown port status update reason code: " ++ show code) ------------------------------------------ -- Switch Error parser ------------------------------------------ getSwitchError :: Int -> Get SwitchError getSwitchError len = do typ <- getWord16be code <- getWord16be bytes <- getWord8s (len - headerSize - 4) return (code2ErrorType typ code bytes) code2ErrorType :: Word16 -> Word16 -> [Word8] -> SwitchError #if OPENFLOW_VERSION==151 code2ErrorType typ code bytes | typ == 0 = HelloFailed (helloErrorCodesMap ! code) [ chr (fromIntegral b) | b <- takeWhile (/=0) bytes ] | typ == 1 = BadRequest (requestErrorCodeMap ! code) bytes | typ == 2 = BadAction code bytes | typ == 3 = FlowModFailed code bytes #endif #if OPENFLOW_VERSION==152 code2ErrorType typ code bytes | typ == 0 = HelloFailed (helloErrorCodesMap ! code) [ chr (fromIntegral b) | b <- takeWhile (/=0) bytes ] | typ == 1 = BadRequest (requestErrorCodeMap ! code) bytes | typ == 2 = BadAction (actionErrorCodeMap ! code) bytes | typ == 3 = FlowModFailed (flowModErrorCodeMap ! code) bytes #endif #if OPENFLOW_VERSION==1 code2ErrorType typ code bytes | typ == 0 = HelloFailed (helloErrorCodesMap ! code) [ chr (fromIntegral b) | b <- takeWhile (/=0) bytes ] | typ == 1 = BadRequest (requestErrorCodeMap ! code) bytes | typ == 2 = BadAction (actionErrorCodeMap ! code) bytes | typ == 3 = FlowModFailed (flowModErrorCodeMap ! code) bytes | typ == 4 = error "Port mod failed error not yet handled" | typ == 5 = error "Queue op failed error not yet handled" #endif helloErrorCodesMap = Bimap.fromList [ (0, IncompatibleVersions) #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 , (1 , HelloPermissionsError) #endif ] requestErrorCodeMap = Bimap.fromList [ (0, VersionNotSupported), (1 , MessageTypeNotSupported), (2 , StatsRequestTypeNotSupported), (3 , VendorNotSupported), (4, VendorSubtypeNotSupported) #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 , (5 , RequestPermissionsError) #endif #if OPENFLOW_VERSION==1 , (6 , BadRequestLength) , (7, BufferEmpty) , (8, UnknownBuffer) #endif ] actionErrorCodeMap = Bimap.fromList [ (0, UnknownActionType), (1, BadActionLength), (2, UnknownVendorID), (3, UnknownActionTypeForVendor), (4, BadOutPort), (5, BadActionArgument) #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 , (6, ActionPermissionsError) #endif #if OPENFLOW_VERSION==1 , (7, TooManyActions) , (8, InvalidQueue) #endif ] flowModErrorCodeMap = Bimap.fromList [ (0, TablesFull) #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 , (1, OverlappingFlow) , (2, FlowModPermissionsError) , (3, EmergencyModHasTimeouts) #endif #if OPENFLOW_VERSION==1 , (4, BadCommand) , (5, UnsupportedActionList) #endif ] ------------------------------------------ -- FlowRemoved parser ------------------------------------------ #if OPENFLOW_VERSION==151 getFlowRemovedRecord :: Get FlowRemoved getFlowRemovedRecord = do m <- getMatch p <- get rcode <- get skip 1 dur <- getWord32be skip 4 pktCount <- getWord64be byteCount <- getWord64be return $ FlowRemoved m p (code2FlowRemovalReason rcode) (fromIntegral dur) (fromIntegral pktCount) (fromIntegral byteCount) #endif #if OPENFLOW_VERSION==152 getFlowRemovedRecord :: Get FlowRemoved getFlowRemovedRecord = do m <- getMatch p <- getWord16be rcode <- getWord8 skip 1 dur <- getWord32be idle_timeout <- getWord16be skip 6 pktCount <- getWord64be byteCount <- getWord64be return $ FlowRemoved m p (code2FlowRemovalReason rcode) (fromIntegral dur) (fromIntegral idle_timeout) (fromIntegral pktCount) (fromIntegral byteCount) #endif #if OPENFLOW_VERSION==1 getFlowRemovedRecord :: Get FlowRemoved getFlowRemovedRecord = do m <- getMatch cookie <- getWord64be p <- getWord16be rcode <- getWord8 skip 1 dur <- getWord32be dur_nsec <- getWord32be idle_timeout <- getWord16be skip 2 pktCount <- getWord64be byteCount <- getWord64be return $ FlowRemoved m cookie p (code2FlowRemovalReason rcode) (fromIntegral dur) (fromIntegral dur_nsec) (fromIntegral idle_timeout) (fromIntegral pktCount) (fromIntegral byteCount) #endif #if OPENFLOW_VERSION==151 flowRemovalReason2CodeBijection :: Bimap FlowRemovalReason Word8 flowRemovalReason2CodeBijection = Bimap.fromList [(IdleTimerExpired, 0), (HardTimerExpired, 1) ] #endif #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 flowRemovalReason2CodeBijection :: Bimap FlowRemovalReason Word8 flowRemovalReason2CodeBijection = Bimap.fromList [(IdleTimerExpired, 0), (HardTimerExpired, 1), (DeletedByController, 2) ] #endif code2FlowRemovalReason rcode = (Bimap.!>) flowRemovalReason2CodeBijection rcode ----------------------------------------- -- Stats Reply parser ----------------------------------------- getStatsReply :: Int -> Get StatsReply getStatsReply headerLen = do statsType <- getWord16be flags <- getWord16be let bodyLen = headerLen - (headerSize + 4) let moreFlag = flags == 0x0001 if statsType == ofpstFlow then do flowStats <- getFlowStatsReplies bodyLen return (FlowStatsReply moreFlag flowStats) else if statsType == ofpstPort then do portStats <- getPortStatsReplies bodyLen return (PortStatsReply moreFlag portStats) else if statsType == ofpstAggregate then do aggStats <- getAggregateStatsReplies bodyLen return (AggregateFlowStatsReply aggStats) else if statsType == ofpstTable then do tableStats <- getTableStatsReplies bodyLen return (TableStatsReply moreFlag tableStats) else if statsType == ofpstDesc then do desc <- getDescriptionReply return (DescriptionReply desc) else #if OPENFLOW_VERSION==1 if statsType == ofpstQueue then do queueStats <- getQueueStatsReplies bodyLen return (QueueStatsReply moreFlag queueStats) else #endif error ("unhandled stats reply message with type: " ++ show statsType) #if OPENFLOW_VERSION==1 getQueueStatsReplies :: Int -> Get [QueueStats] getQueueStatsReplies bodyLen = do sequence (replicate cnt getQueueStatsReply) where cnt = let (d,m) = bodyLen `divMod` queueStatsLength in if m == 0 then d else error ("Body of queue stats reply must be a multiple of " ++ show queueStatsLength) queueStatsLength = 32 getQueueStatsReply = do portNo <- getWord16be skip 2 qid <- getWord32be tx_bytes <- getWord64be tx_packets <- getWord64be tx_errs <- getWord64be return (QueueStats { queueStatsPortID = portNo, queueStatsQueueID = qid, queueStatsTransmittedBytes = fromIntegral tx_bytes, queueStatsTransmittedPackets = fromIntegral tx_packets, queueStatsTransmittedErrors = fromIntegral tx_errs }) #endif getDescriptionReply :: Get Description getDescriptionReply = do mfr <- getCharsRightPadded descLen hw <- getCharsRightPadded descLen sw <- getCharsRightPadded descLen serial <- getCharsRightPadded descLen dp <- getCharsRightPadded serialNumLen return ( Description { manufacturerDesc = mfr , hardwareDesc = hw , softwareDesc = sw , serialNumber = serial #if OPENFLOW_VERSION==1 , datapathDesc = dp #endif } ) where descLen = 256 serialNumLen = 32 getCharsRightPadded :: Int -> Get String getCharsRightPadded n = do bytes <- getWord8s n return [ chr (fromIntegral b) | b <- takeWhile (/=0) bytes] getTableStatsReplies :: Int -> Get [TableStats] getTableStatsReplies bodyLen = sequence (replicate cnt getTableStatsReply) where cnt = let (d,m) = bodyLen `divMod` tableStatsLength in if m == 0 then d else error ("Body of Table stats reply must be a multiple of " ++ show tableStatsLength) tableStatsLength = 64 getTableStatsReply :: Get TableStats getTableStatsReply = do tableID <- getWord8 skip 3 name_bytes <- getWord8s maxTableNameLen let name = [ chr (fromIntegral b) | b <- name_bytes ] wcards <- getWord32be maxEntries <- getWord32be activeCount <- getWord32be lookupCount <- getWord64be matchedCount <- getWord64be return ( TableStats { tableStatsTableID = tableID, tableStatsTableName = name, tableStatsMaxEntries = fromIntegral maxEntries, tableStatsActiveCount = fromIntegral activeCount, tableStatsLookupCount = fromIntegral lookupCount, tableStatsMatchedCount = fromIntegral matchedCount } ) where maxTableNameLen = 32 getFlowStatsReplies :: Int -> Get [FlowStats] getFlowStatsReplies bodyLen | bodyLen == 0 = return [] | otherwise = do (fs,fsLen) <- getFlowStatsReply rest <- getFlowStatsReplies (bodyLen - fsLen) return (fs : rest) getFlowStatsReply :: Get (FlowStats, Int) getFlowStatsReply = do len <- getWord16be tid <- getWord8 skip 1 match <- getMatch dur_sec <- getWord32be #if OPENFLOW_VERSION==1 dur_nanosec <- getWord32be #endif priority <- getWord16be idle_to <- getWord16be hard_to <- getWord16be #if OPENFLOW_VERSION==151 skip 6 #endif #if OPENFLOW_VERSION==152 skip 2 #endif #if OPENFLOW_VERSION==1 skip 6 cookie <- getWord64be #endif packet_count <- getWord64be byte_count <- getWord64be let numActions = (fromIntegral len - flowStatsReplySize) `div` actionSize actions <- sequence (replicate numActions getAction) let stats = FlowStats { flowStatsTableID = tid, flowStatsMatch = match, flowStatsDurationSeconds = fromIntegral dur_sec, #if OPENFLOW_VERSION==1 flowStatsDurationNanoseconds = fromIntegral dur_nanosec, #endif flowStatsPriority = priority, flowStatsIdleTimeout = fromIntegral idle_to, flowStatsHardTimeout = fromIntegral hard_to, #if OPENFLOW_VERSION==1 flowStatsCookie = cookie, #endif flowStatsPacketCount = fromIntegral packet_count, flowStatsByteCount = fromIntegral byte_count, flowStatsActions = actions } return (stats, fromIntegral len) where actionSize = 8 #if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152 flowStatsReplySize = 72 #endif #if OPENFLOW_VERSION==1 flowStatsReplySize = 88 #endif getAction :: Get Action getAction = do action_type <- getWord16be action_len <- getWord16be getActionForType (code2ActionType action_type) action_len getActionForType :: ActionType -> Word16 -> Get Action getActionForType OutputToPortType _ = do port <- getWord16be max_len <- getWord16be return (SendOutPort (action port max_len)) where action port max_len | port <= 0xff00 = PhysicalPort port | port == ofppInPort = InPort | port == ofppFlood = Flood | port == ofppAll = AllPhysicalPorts | port == ofppController = ToController max_len | port == ofppTable = WithTable getActionForType SetVlanVIDType _ = do vlanid <- getWord16be skip 2 return (SetVlanVID vlanid) getActionForType SetVlanPriorityType _ = do pcp <- getWord8 skip 3 return (SetVlanPriority pcp) getActionForType StripVlanHeaderType _ = do skip 4 return StripVlanHeader getActionForType SetEthSrcAddrType _ = do addr <- getEthernetAddress skip 6 return (SetEthSrcAddr addr) getActionForType SetEthDstAddrType _ = do addr <- getEthernetAddress skip 6 return (SetEthDstAddr addr) getActionForType SetIPSrcAddrType _ = do addr <- getIPAddress return (SetIPSrcAddr addr) getActionForType SetIPDstAddrType _ = do addr <- getIPAddress return (SetIPDstAddr addr) #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 getActionForType SetIPTypeOfServiceType _ = do tos <- getWord8 skip 3 return (SetIPToS tos) #endif getActionForType SetTransportSrcPortType _ = do port <- getWord16be return (SetTransportSrcPort port) getActionForType SetTransportDstPortType _ = do port <- getWord16be return (SetTransportDstPort port) #if OPENFLOW_VERSION==1 getActionForType EnqueueType _ = do port <- getWord16be skip 6 qid <- getWord32be return (Enqueue port qid) getActionForType VendorActionType action_len = do vendorid <- getWord32be bytes <- getWord8s (fromIntegral action_len - 2 - 2 - 4) return (VendorAction vendorid bytes) #endif getAggregateStatsReplies :: Int -> Get AggregateFlowStats getAggregateStatsReplies bodyLen = do pkt_cnt <- getWord64be byte_cnt <- getWord64be flow_cnt <- getWord32be skip 4 return (AggregateFlowStats (fromIntegral pkt_cnt) (fromIntegral byte_cnt) (fromIntegral flow_cnt)) getPortStatsReplies :: Int -> Get [(PortID,PortStats)] getPortStatsReplies bodyLen = sequence (replicate numPorts getPortStatsReply) where numPorts = bodyLen `div` portStatsSize portStatsSize = 104 getPortStatsReply :: Get (PortID, PortStats) getPortStatsReply = do port_no <- getWord16be skip 6 rx_packets <- getWord64be tx_packets <- getWord64be rx_bytes <- getWord64be tx_bytes <- getWord64be rx_dropped <- getWord64be tx_dropped <- getWord64be rx_errors <- getWord64be tx_errors <- getWord64be rx_frame_err <- getWord64be rx_over_err <- getWord64be rx_crc_err <- getWord64be collisions <- getWord64be return $ (port_no, PortStats { portStatsReceivedPackets = checkValid rx_packets, portStatsSentPackets = checkValid tx_packets, portStatsReceivedBytes = checkValid rx_bytes, portStatsSentBytes = checkValid tx_bytes, portStatsReceiverDropped = checkValid rx_dropped, portStatsSenderDropped = checkValid tx_dropped, portStatsReceiveErrors = checkValid rx_errors, portStatsTransmitError = checkValid tx_errors, portStatsReceivedFrameErrors = checkValid rx_frame_err, portStatsReceiverOverrunError = checkValid rx_over_err, portStatsReceiverCRCError = checkValid rx_crc_err, portStatsCollisions = checkValid collisions } ) where checkValid :: Word64 -> Maybe Double checkValid x = if x == -1 then Nothing else Just (fromIntegral x) ---------------------------------------------- -- Unparsers for CSMessages ---------------------------------------------- -- | Unparser for @CSMessage@s putCSMessage :: (M.TransactionID, M.CSMessage) -> Put putCSMessage (xid, msg) = case msg of M.CSHello -> putH ofptHello headerSize M.CSEchoRequest bytes -> do putH ofptEchoRequest (headerSize + length bytes) putWord8s bytes M.CSEchoReply bytes -> do putH ofptEchoReply (headerSize + length bytes) putWord8s bytes M.FeaturesRequest -> putH ofptFeaturesRequest headerSize M.PacketOut packetOut -> do putH ofptPacketOut (sendPacketSizeInBytes packetOut) putSendPacket packetOut M.FlowMod mod -> do let mod'@(FlowModRecordInternal {..}) = flowModToFlowModInternal mod putH ofptFlowMod (flowModSizeInBytes' actions') putFlowMod mod' M.PortMod portModRecord -> do putH ofptPortMod portModLength putPortMod portModRecord #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 M.BarrierRequest -> do putH ofptBarrierRequest headerSize #endif M.StatsRequest request -> do putH ofptStatsRequest (statsRequestSize request) putStatsRequest request where vid = ofpVersion putH tcode len = putHeader (OFPHeader vid tcode (fromIntegral len) xid) ------------------------------------------ -- Unparser for packet out message ------------------------------------------ sendPacketSizeInBytes :: PacketOut -> Int sendPacketSizeInBytes (PacketOut bufferIDData _ actions) = headerSize + 4 + 2 + 2 + sum (map actionSizeInBytes actions) + fromIntegral (either (const 0) B.length bufferIDData) putSendPacket :: PacketOut -> Put putSendPacket (PacketOut {..}) = do putWord32be $ either id (const (-1)) bufferIDData maybe (putWord16be ofppNone) putWord16be inPort putWord16be (fromIntegral actionArraySize) sequence_ [putAction a | a <- actions] either (const $ return ()) putLazyByteString bufferIDData where actionArraySize = sum $ map actionSizeInBytes actions ------------------------------------------ -- Unparser for flow mod message ------------------------------------------ #if OPENFLOW_VERSION==151 flowModSizeInBytes' :: [Action] -> Int flowModSizeInBytes' actions = headerSize + matchSize + 20 + sum (map actionSizeInBytes actions) #endif #if OPENFLOW_VERSION==152 flowModSizeInBytes' :: [Action] -> Int flowModSizeInBytes' actions = headerSize + matchSize + 20 + sum (map actionSizeInBytes actions) #endif #if OPENFLOW_VERSION==1 flowModSizeInBytes' :: [Action] -> Int flowModSizeInBytes' actions = headerSize + matchSize + 24 + sum (map actionSizeInBytes actions) #endif data FlowModRecordInternal = FlowModRecordInternal { command' :: FlowModType , match' :: Match , actions' :: [Action] , priority' :: Priority , idleTimeOut' :: Maybe TimeOut , hardTimeOut' :: Maybe TimeOut #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 , flags' :: [FlowModFlag] #endif , bufferID' :: Maybe BufferID , outPort' :: Maybe PseudoPort #if OPENFLOW_VERSION==1 , cookie' :: Cookie #endif } deriving (Eq,Show) -- | Specification: @ofp_flow_mod_command@. data FlowModType = FlowAddType | FlowModifyType | FlowModifyStrictType | FlowDeleteType | FlowDeleteStrictType deriving (Show,Eq,Ord) #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 -- | A set of flow mod attributes can be added to a flow modification command. data FlowModFlag = SendFlowRemoved | CheckOverlap | Emergency deriving (Show,Eq,Ord,Enum) #endif flowModToFlowModInternal :: FlowMod -> FlowModRecordInternal flowModToFlowModInternal (DeleteFlows {..}) = FlowModRecordInternal {match' = match, #if OPENFLOW_VERSION==1 cookie' = 0, #endif command' = FlowDeleteType, idleTimeOut' = Nothing, hardTimeOut' = Nothing, priority' = 0, bufferID' = Nothing, outPort' = outPort, #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 flags' = [], #endif actions' = [] } flowModToFlowModInternal (DeleteExactFlow {..}) = FlowModRecordInternal {match' = match, #if OPENFLOW_VERSION==1 cookie' = 0, #endif command' = FlowDeleteStrictType, idleTimeOut' = Nothing, hardTimeOut' = Nothing, priority' = priority, bufferID' = Nothing, outPort' = outPort, #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 flags' = [], #endif actions' = [] } flowModToFlowModInternal (AddFlow {..}) = FlowModRecordInternal { match' = match, #if OPENFLOW_VERSION==1 cookie' = cookie, #endif command' = FlowAddType, idleTimeOut' = Just idleTimeOut, hardTimeOut' = Just hardTimeOut, priority' = priority, bufferID' = applyToPacket, outPort' = Nothing, #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 flags' = concat [ if not overlapAllowed then [CheckOverlap] else [], if notifyWhenRemoved then [SendFlowRemoved] else []] , #endif actions' = actions } flowModToFlowModInternal (AddEmergencyFlow {..}) = FlowModRecordInternal { match' = match, #if OPENFLOW_VERSION==1 cookie' = cookie, #endif command' = FlowAddType, idleTimeOut' = Nothing, hardTimeOut' = Nothing, priority' = priority, bufferID' = Nothing, outPort' = Nothing, #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 flags' = Emergency : if not overlapAllowed then [CheckOverlap] else [], #endif actions' = actions } flowModToFlowModInternal (ModifyFlows {..}) = FlowModRecordInternal {match' = match, #if OPENFLOW_VERSION==1 cookie' = ifMissingCookie, #endif command' = FlowModifyType, idleTimeOut' = Just ifMissingIdleTimeOut, hardTimeOut' = Just ifMissingHardTimeOut, priority' = ifMissingPriority, bufferID' = Nothing, outPort' = Nothing, #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 flags' = concat [ if not ifMissingOverlapAllowed then [CheckOverlap] else [], if ifMissingNotifyWhenRemoved then [SendFlowRemoved] else []] , #endif actions' = newActions } flowModToFlowModInternal (ModifyExactFlow {..}) = FlowModRecordInternal {match' = match, #if OPENFLOW_VERSION==1 cookie' = ifMissingCookie, #endif command' = FlowModifyStrictType, idleTimeOut' = Just ifMissingIdleTimeOut, hardTimeOut' = Just ifMissingHardTimeOut, priority' = priority, bufferID' = Nothing, outPort' = Nothing, #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 flags' = concat [ if not ifMissingOverlapAllowed then [CheckOverlap] else [], if ifMissingNotifyWhenRemoved then [SendFlowRemoved] else []] , #endif actions' = newActions } #if OPENFLOW_VERSION==151 putFlowMod :: FlowModRecordInternal -> Put putFlowMod (FlowModRecordInternal {..}) = do putMatch match' putWord16be $ flowModTypeBimap ! command' putWord16be $ maybeTimeOutToCode idleTimeOut' putWord16be $ maybeTimeOutToCode hardTimeOut' putWord16be priority' putWord32be $ maybe (-1) id bufferID' putWord16be $ maybe ofppNone fakePort2Code outPort' putWord16be 0 putWord32be 0 sequence_ [putAction a | a <- actions'] #endif #if OPENFLOW_VERSION==152 putFlowMod :: FlowModRecordInternal -> Put putFlowMod (FlowModRecordInternal {..}) = do putMatch match' putWord16be $ flowModTypeBimap ! command' putWord16be $ maybeTimeOutToCode idleTimeOut' putWord16be $ maybeTimeOutToCode hardTimeOut' putWord16be priority' putWord32be $ maybe (-1) id bufferID' putWord16be $ maybe ofppNone fakePort2Code outPort' putWord16be $ flagSet2BitMap flags' putWord32be 0 sequence_ [putAction a | a <- actions'] #endif #if OPENFLOW_VERSION==1 putFlowMod :: FlowModRecordInternal -> Put putFlowMod (FlowModRecordInternal {..}) = do putMatch match' putWord64be cookie' putWord16be $ flowModTypeBimap ! command' putWord16be $ maybeTimeOutToCode idleTimeOut' putWord16be $ maybeTimeOutToCode hardTimeOut' putWord16be priority' putWord32be $ maybe (-1) id bufferID' putWord16be $ maybe ofppNone fakePort2Code outPort' putWord16be $ flagSet2BitMap flags' sequence_ [putAction a | a <- actions'] #endif maybeTimeOutToCode :: Maybe TimeOut -> Word16 maybeTimeOutToCode Nothing = 0 maybeTimeOutToCode (Just to) = case to of Permanent -> 0 ExpireAfter t -> t #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 flagSet2BitMap :: [FlowModFlag] -> Word16 flagSet2BitMap flagSet = foldl (.|.) 0 bitMasks where bitMasks = map (\f -> fromJust $ lookup f flowModFlagToBitMaskBijection) flagSet flowModFlagToBitMaskBijection :: [(FlowModFlag,Word16)] flowModFlagToBitMaskBijection = [(SendFlowRemoved, shiftL 1 0), (CheckOverlap, shiftL 1 1), (Emergency, shiftL 1 2) ] #endif ofpfcAdd, ofpfcModify, ofpfcModifyStrict, ofpfcDelete, ofpfcDeleteStrict :: Word16 ofpfcAdd = 0 ofpfcModify = 1 ofpfcModifyStrict = 2 ofpfcDelete = 3 ofpfcDeleteStrict = 4 flowModTypeBimap :: Bimap FlowModType Word16 flowModTypeBimap = Bimap.fromList [ (FlowAddType, ofpfcAdd), (FlowModifyType, ofpfcModify), (FlowModifyStrictType, ofpfcModifyStrict), (FlowDeleteType, ofpfcDelete), (FlowDeleteStrictType, ofpfcDeleteStrict) ] putAction :: Action -> Put putAction act = do putWord16be $ actionType2Code $ typeOfAction act putWord16be (fromIntegral $ actionSizeInBytes act) case act of (SendOutPort port) -> do putPseudoPort port (SetVlanVID vlanid) -> do putWord16be vlanid putWord16be 0 (SetVlanPriority priority) -> do putWord8 priority putWord8 0 putWord8 0 putWord8 0 (StripVlanHeader) -> do putWord32be 0 (SetEthSrcAddr addr) -> do putEthernetAddress addr sequence_ (replicate 6 (putWord8 0)) (SetEthDstAddr addr) -> do putEthernetAddress addr sequence_ (replicate 6 (putWord8 0)) (SetIPSrcAddr addr) -> do putWord32be (ipAddressToWord32 addr) (SetIPDstAddr addr) -> do putWord32be (ipAddressToWord32 addr) #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 (SetIPToS tos) -> do putWord8 tos sequence_ (replicate 3 (putWord8 0)) #endif (SetTransportSrcPort port) -> do putWord16be port putWord16be 0 (SetTransportDstPort port) -> do putWord16be port putWord16be 0 #if OPENFLOW_VERSION==1 (Enqueue port qid) -> do putWord16be port sequence_ (replicate 6 (putWord8 0)) putWord32be qid (VendorAction vendorID bytes) -> do putWord32be vendorID put bytes #endif putPseudoPort :: PseudoPort -> Put putPseudoPort (ToController maxLen) = do putWord16be ofppController putWord16be maxLen putPseudoPort port = do putWord16be (fakePort2Code port) putWord16be 0 actionSizeInBytes :: Action -> Int actionSizeInBytes (SendOutPort _) = 8 actionSizeInBytes (SetVlanVID _) = 8 actionSizeInBytes (SetVlanPriority _) = 8 actionSizeInBytes StripVlanHeader = 8 actionSizeInBytes (SetEthSrcAddr _) = 16 actionSizeInBytes (SetEthDstAddr _) = 16 actionSizeInBytes (SetIPSrcAddr _) = 8 actionSizeInBytes (SetIPDstAddr _) = 8 #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 actionSizeInBytes (SetIPToS _) = 8 #endif actionSizeInBytes (SetTransportSrcPort _) = 8 actionSizeInBytes (SetTransportDstPort _) = 8 #if OPENFLOW_VERSION==1 actionSizeInBytes (Enqueue _ _) = 16 actionSizeInBytes (VendorAction _ bytes) = let l = 2 + 2 + 4 + length bytes in if l `mod` 8 /= 0 then error "Vendor action must have enough data to make the action length a multiple of 8 bytes" else l #endif typeOfAction :: Action -> ActionType typeOfAction a = case a of SendOutPort _ -> OutputToPortType SetVlanVID _ -> SetVlanVIDType SetVlanPriority _ -> SetVlanPriorityType StripVlanHeader -> StripVlanHeaderType SetEthSrcAddr _ -> SetEthSrcAddrType SetEthDstAddr _ -> SetEthDstAddrType SetIPSrcAddr _ -> SetIPSrcAddrType SetIPDstAddr _ -> SetIPDstAddrType #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 SetIPToS _ -> SetIPTypeOfServiceType #endif SetTransportSrcPort _ -> SetTransportSrcPortType SetTransportDstPort _ -> SetTransportDstPortType #if OPENFLOW_VERSION==1 Enqueue _ _ -> EnqueueType VendorAction _ _ -> VendorActionType #endif ------------------------------------------ -- Port mod unparser ------------------------------------------ portModLength :: Word16 portModLength = 32 putPortMod :: PortMod -> Put putPortMod (PortMod {..} ) = do putWord16be portNumber putEthernetAddress hwAddr putConfigBitMap putMaskBitMap putAdvertiseBitMap putPad where putConfigBitMap = putWord32be (portAttributeSet2BitMask onAttrs) putMaskBitMap = putWord32be (portAttributeSet2BitMask offAttrs) putAdvertiseBitMap = putWord32be 0 putPad = putWord32be 0 attrsChanging = List.union onAttrs offAttrs onAttrs = Map.keys $ Map.filter (==True) attributesToSet offAttrs = Map.keys $ Map.filter (==False) attributesToSet ---------------------------------------- -- Stats requests unparser ---------------------------------------- statsRequestSize :: StatsRequest -> Int statsRequestSize (FlowStatsRequest _ _ _) = headerSize + 2 + 2 + matchSize + 1 + 1 + 2 #if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152 statsRequestSize (PortStatsRequest) = headerSize + 2 + 2 #endif #if OPENFLOW_VERSION==1 statsRequestSize (PortStatsRequest _) = headerSize + 2 + 2 + 2 + 6 #endif putStatsRequest :: StatsRequest -> Put putStatsRequest (FlowStatsRequest match tableQuery mPort) = do putWord16be ofpstFlow putWord16be 0 putMatch match putWord8 (tableQueryToCode tableQuery) putWord8 0 --pad putWord16be $ maybe ofppNone fakePort2Code mPort putStatsRequest (AggregateFlowStatsRequest match tableQuery mPort) = do putWord16be ofpstAggregate putWord16be 0 putMatch match putWord8 (tableQueryToCode tableQuery) putWord8 0 --pad putWord16be $ maybe ofppNone fakePort2Code mPort putStatsRequest TableStatsRequest = do putWord16be ofpstTable putWord16be 0 putStatsRequest DescriptionRequest = do putWord16be ofpstDesc putWord16be 0 #if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152 putStatsRequest PortStatsRequest = do putWord16be ofpstPort putWord16be 0 #endif #if OPENFLOW_VERSION==1 putStatsRequest (QueueStatsRequest portQuery queueQuery) = do putWord16be ofpstQueue putWord16be 0 putWord16be (queryToPortNumber portQuery) putWord16be 0 --padding putWord32be (queryToQueueID queueQuery) putStatsRequest (PortStatsRequest query) = do putWord16be ofpstPort putWord16be 0 putWord16be (queryToPortNumber query) sequence_ (replicate 6 (putWord8 0)) queryToPortNumber :: PortQuery -> Word16 queryToPortNumber AllPorts = ofppNone queryToPortNumber (SinglePort p) = p queryToQueueID :: QueueQuery -> QueueID queryToQueueID AllQueues = 0xffffffff queryToQueueID (SingleQueue q) = q #endif ofppInPort, ofppTable, ofppNormal, ofppFlood, ofppAll, ofppController, ofppLocal, ofppNone :: Word16 ofppInPort = 0xfff8 ofppTable = 0xfff9 ofppNormal = 0xfffa ofppFlood = 0xfffb ofppAll = 0xfffc ofppController = 0xfffd ofppLocal = 0xfffe ofppNone = 0xffff fakePort2Code :: PseudoPort -> Word16 fakePort2Code (PhysicalPort portID) = portID fakePort2Code InPort = ofppInPort fakePort2Code Flood = ofppFlood fakePort2Code AllPhysicalPorts = ofppAll fakePort2Code (ToController _) = ofppController fakePort2Code NormalSwitching = ofppNormal fakePort2Code WithTable = ofppTable tableQueryToCode :: TableQuery -> Word8 tableQueryToCode AllTables = 0xff #if OPENFLOW_VERSION==1 tableQueryToCode EmergencyTable = 0xfe #endif tableQueryToCode (Table t) = t #if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152 ofpstDesc, ofpstFlow, ofpstAggregate, ofpstTable, ofpstPort, ofpstVendor :: Word16 ofpstDesc = 0 ofpstFlow = 1 ofpstAggregate = 2 ofpstTable = 3 ofpstPort = 4 ofpstVendor = 0xffff #endif #if OPENFLOW_VERSION==1 ofpstDesc, ofpstFlow, ofpstAggregate, ofpstTable, ofpstPort, ofpstQueue, ofpstVendor :: Word16 ofpstDesc = 0 ofpstFlow = 1 ofpstAggregate = 2 ofpstTable = 3 ofpstPort = 4 ofpstQueue = 5 ofpstVendor = 0xffff #endif --------------------------------------------- -- Parser and Unparser for Match --------------------------------------------- #if OPENFLOW_VERSION==151 matchSize :: Int matchSize = 36 #endif #if OPENFLOW_VERSION==152 matchSize :: Int matchSize = 40 #endif #if OPENFLOW_VERSION==1 matchSize :: Int matchSize = 40 #endif #if OPENFLOW_VERSION==151 getMatch :: Get Match getMatch = do wcards <- getWord32be inport <- getWord16be srcEthAddr <- getEthernetAddress dstEthAddr <- getEthernetAddress dl_vlan <- getWord16be dl_type <- getWord16be nw_proto <- getWord8 getWord8 nw_src <- getWord32be nw_dst <- getWord32be tp_src <- getWord16be tp_dst <- getWord16be return $ ofpMatch2Match $ OFPMatch wcards inport srcEthAddr dstEthAddr dl_vlan dl_type nw_proto nw_src nw_dst tp_src tp_dst putMatch :: Match -> Put putMatch m = do putWord32be $ ofpm_wildcards m' putWord16be $ ofpm_in_port m' putEthernetAddress $ ofpm_dl_src m' putEthernetAddress $ ofpm_dl_dst m' putWord16be $ ofpm_dl_vlan m' putWord16be $ ofpm_dl_type m' putWord8 $ ofpm_nw_proto m' putWord8 0 -- padding putWord32be $ ofpm_nw_src m' putWord32be $ ofpm_nw_dst m' putWord16be $ ofpm_tp_src m' putWord16be $ ofpm_tp_dst m' where m' = match2OFPMatch m #endif #if OPENFLOW_VERSION==152 getMatch :: Get Match getMatch = do wcards <- getWord32be inport <- getWord16be srcEthAddr <- getEthernetAddress dstEthAddr <- getEthernetAddress dl_vlan <- getWord16be dl_vlan_pcp <- get skip 1 dl_type <- getWord16be nw_proto <- getWord8 skip 3 nw_src <- getWord32be nw_dst <- getWord32be tp_src <- getWord16be tp_dst <- getWord16be return $ ofpMatch2Match $ OFPMatch wcards inport srcEthAddr dstEthAddr dl_vlan dl_vlan_pcp dl_type nw_proto nw_src nw_dst tp_src tp_dst putMatch :: Match -> Put putMatch m = do putWord32be $ ofpm_wildcards m' putWord16be $ ofpm_in_port m' putEthernetAddress $ ofpm_dl_src m' putEthernetAddress $ ofpm_dl_dst m' putWord16be $ ofpm_dl_vlan m' putWord8 $ ofpm_dl_vlan_pcp m' putWord8 0 -- padding putWord16be $ ofpm_dl_type m' putWord8 $ ofpm_nw_proto m' putWord8 0 -- padding putWord8 0 -- padding putWord8 0 -- padding putWord32be $ ofpm_nw_src m' putWord32be $ ofpm_nw_dst m' putWord16be $ ofpm_tp_src m' putWord16be $ ofpm_tp_dst m' where m' = match2OFPMatch m #endif #if OPENFLOW_VERSION==1 getMatch :: Get Match getMatch = do wcards <- getWord32be inport <- getWord16be srcEthAddr <- getEthernetAddress dstEthAddr <- getEthernetAddress dl_vlan <- getWord16be dl_vlan_pcp <- getWord8 skip 1 dl_type <- getWord16be nw_tos <- getWord8 nw_proto <- getWord8 skip 2 nw_src <- getWord32be nw_dst <- getWord32be tp_src <- getWord16be tp_dst <- getWord16be return $ ofpMatch2Match $ OFPMatch wcards inport srcEthAddr dstEthAddr dl_vlan dl_vlan_pcp dl_type nw_tos nw_proto nw_src nw_dst tp_src tp_dst putMatch :: Match -> Put putMatch m = do putWord32be $ ofpm_wildcards m' putWord16be $ ofpm_in_port m' putEthernetAddress $ ofpm_dl_src m' putEthernetAddress $ ofpm_dl_dst m' putWord16be $ ofpm_dl_vlan m' putWord8 $ ofpm_dl_vlan_pcp m' putWord8 0 -- padding putWord16be $ ofpm_dl_type m' putWord8 $ ofpm_nw_tos m' putWord8 $ ofpm_nw_proto m' putWord8 0 -- padding putWord8 0 -- padding putWord32be $ ofpm_nw_src m' putWord32be $ ofpm_nw_dst m' putWord16be $ ofpm_tp_src m' putWord16be $ ofpm_tp_dst m' where m' = match2OFPMatch m #endif data OFPMatch = OFPMatch { ofpm_wildcards :: Word32, ofpm_in_port :: Word16, ofpm_dl_src, ofpm_dl_dst :: EthernetAddress, ofpm_dl_vlan :: Word16, #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 ofpm_dl_vlan_pcp :: Word8, #endif ofpm_dl_type :: Word16, #if OPENFLOW_VERSION==1 ofpm_nw_tos :: Word8, #endif ofpm_nw_proto :: Word8, ofpm_nw_src, ofpm_nw_dst :: Word32, ofpm_tp_src, ofpm_tp_dst :: Word16 } deriving (Show,Eq) ofpMatch2Match :: OFPMatch -> Match ofpMatch2Match ofpm = Match (getField 0 ofpm_in_port) (getField 2 ofpm_dl_src) (getField 3 ofpm_dl_dst) (getField 1 ofpm_dl_vlan) #if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 (getField 20 ofpm_dl_vlan_pcp) #endif (getField 4 ofpm_dl_type) #if OPENFLOW_VERSION==1 (getField 21 ofpm_nw_tos) #endif (getField 5 ofpm_nw_proto) (IPAddress (ofpm_nw_src ofpm) // src_prefix_len) (IPAddress (ofpm_nw_dst ofpm) // dst_prefix_len) (getField 6 ofpm_tp_src) (getField 7 ofpm_tp_dst) where getField wcindex getter = if testBit (ofpm_wildcards ofpm) wcindex then Nothing else Just (getter ofpm) nw_src_shift = 8 nw_dst_shift = 14 nw_src_mask = shiftL ((shiftL 1 6) - 1) nw_src_shift nw_dst_mask = shiftL ((shiftL 1 6) - 1) nw_dst_shift nw_src_num_ignored = fromIntegral (shiftR (ofpm_wildcards ofpm .&. nw_src_mask) nw_src_shift) nw_dst_num_ignored = fromIntegral (shiftR (ofpm_wildcards ofpm .&. nw_dst_mask) nw_dst_shift) src_prefix_len = 32 - min 32 nw_src_num_ignored dst_prefix_len = 32 - min 32 nw_dst_num_ignored #if OPENFLOW_VERSION==151 match2OFPMatch :: Match -> OFPMatch match2OFPMatch (Match {..}) = foldl (\a f -> f a) m0 fieldSetters where m0 = OFPMatch 0 0 nullEthAddr nullEthAddr 0 0 0 nwsrcaddr nwdstaddr 0 0 fieldSetters = [setInPort, setDLSrc, setDLDst, setDLVLan, setDLType, setNWProto, setTPSrc, setTPDst, updateNWSrcWildcard, updateNWDstWildcard] setInPort = adjust 0 updateInPort 0 inPort setDLSrc = adjust 2 updateDLSrc nullEthAddr srcEthAddress setDLDst = adjust 3 updateDLDst nullEthAddr dstEthAddress setDLVLan = adjust 1 updateDLVLan 0 vLANID setDLType = adjust 4 updateDLType 0 ethFrameType setNWProto = adjust 5 updateNWProto 0 ipProtocol setTPSrc = adjust 6 updateTPSrc 0 srcTransportPort setTPDst = adjust 7 updateTPDst 0 dstTransportPort nwsrcaddr = fromIntegral $ ipAddressToWord32 $ addressPart srcIPAddress nwdstaddr = fromIntegral $ ipAddressToWord32 $ addressPart dstIPAddress modifyWildcardBits f m' = m' { ofpm_wildcards = f (ofpm_wildcards m') } updateNWSrcWildcard = let numIgnoredBits = 32 - (prefixLength srcIPAddress) f wc = wc .|. shiftL (fromIntegral numIgnoredBits) 8 in modifyWildcardBits f updateNWDstWildcard = let numIgnoredBits = 32 - (prefixLength dstIPAddress) f wc = wc .|. shiftL (fromIntegral numIgnoredBits) 14 in modifyWildcardBits f nullEthAddr = EthernetAddress 0 0 0 0 0 0 setWildcardBit i m' = m' { ofpm_wildcards = setBit (ofpm_wildcards m') i } clearWildcardBit i m' = m' { ofpm_wildcards = clearBit (ofpm_wildcards m') i } updateInPort v m' = m' { ofpm_in_port = v } updateDLSrc v m' = m' { ofpm_dl_src = v } updateDLDst v m' = m' { ofpm_dl_dst = v } updateDLVLan v m' = m' { ofpm_dl_vlan = v } updateDLType v m' = m' { ofpm_dl_type = v } updateNWProto v m'= m' { ofpm_nw_proto = v } updateNWSrc v m' = m' { ofpm_nw_src = v } updateNWDst v m' = m' { ofpm_nw_dst = v } updateTPSrc v m' = m' { ofpm_tp_src = v } updateTPDst v m' = m' { ofpm_tp_dst = v } adjust wildcardIndex updater nullValue mv m' = case mv of Nothing -> setWildcardBit wildcardIndex $ updater nullValue m' Just v -> clearWildcardBit wildcardIndex $ updater v m' #endif #if OPENFLOW_VERSION==152 match2OFPMatch :: Match -> OFPMatch match2OFPMatch (Match {..}) = foldl (\a f -> f a) m0 fieldSetters where m0 = OFPMatch 0 0 nullEthAddr nullEthAddr 0 0 0 0 nwsrcaddr nwdstaddr 0 0 fieldSetters = [setInPort, setDLSrc, setDLDst, setDLVLan, setDLVLanPriority, setDLType, setNWProto, setTPSrc, setTPDst, updateNWSrcWildcard, updateNWDstWildcard] setInPort = adjust 0 updateInPort 0 inPort setDLSrc = adjust 2 updateDLSrc nullEthAddr srcEthAddress setDLDst = adjust 3 updateDLDst nullEthAddr dstEthAddress setDLVLan = adjust 1 updateDLVLan 0 vLANID setDLVLanPriority = adjust 20 updateDLVLanPcp 0 vLANPriority setDLType = adjust 4 updateDLType 0 ethFrameType setNWProto = adjust 5 updateNWProto 0 ipProtocol setTPSrc = adjust 6 updateTPSrc 0 srcTransportPort setTPDst = adjust 7 updateTPDst 0 dstTransportPort nwsrcaddr = fromIntegral $ ipAddressToWord32 $ addressPart srcIPAddress nwdstaddr = fromIntegral $ ipAddressToWord32 $ addressPart dstIPAddress modifyWildcardBits f m' = m' { ofpm_wildcards = f (ofpm_wildcards m') } updateNWSrcWildcard = let numIgnoredBits = 32 - (prefixLength srcIPAddress) f wc = wc .|. shiftL (fromIntegral numIgnoredBits) 8 in modifyWildcardBits f updateNWDstWildcard = let numIgnoredBits = 32 - (prefixLength dstIPAddress) f wc = wc .|. shiftL (fromIntegral numIgnoredBits) 14 in modifyWildcardBits f nullEthAddr = EthernetAddress 0 0 0 0 0 0 setWildcardBit i m' = m' { ofpm_wildcards = setBit (ofpm_wildcards m') i } clearWildcardBit i m' = m' { ofpm_wildcards = clearBit (ofpm_wildcards m') i } updateInPort v m' = m' { ofpm_in_port = v } updateDLSrc v m' = m' { ofpm_dl_src = v } updateDLDst v m' = m' { ofpm_dl_dst = v } updateDLVLan v m' = m' { ofpm_dl_vlan = v } updateDLVLanPcp v m' = m' { ofpm_dl_vlan_pcp = v } updateDLType v m' = m' { ofpm_dl_type = v } updateNWProto v m'= m' { ofpm_nw_proto = v } updateNWSrc v m' = m' { ofpm_nw_src = v } updateNWDst v m' = m' { ofpm_nw_dst = v } updateTPSrc v m' = m' { ofpm_tp_src = v } updateTPDst v m' = m' { ofpm_tp_dst = v } adjust wildcardIndex updater nullValue mv m' = case mv of Nothing -> setWildcardBit wildcardIndex $ updater nullValue m' Just v -> clearWildcardBit wildcardIndex $ updater v m' #endif #if OPENFLOW_VERSION==1 match2OFPMatch :: Match -> OFPMatch match2OFPMatch (Match {..}) = foldl (\a f -> f a) m0 fieldSetters where m0 = OFPMatch { ofpm_wildcards = 0, ofpm_in_port = 0, ofpm_dl_src = nullEthAddr, ofpm_dl_dst = nullEthAddr, ofpm_dl_vlan = 0, ofpm_dl_vlan_pcp = 0, ofpm_dl_type = 0, ofpm_nw_tos = 0, ofpm_nw_proto = 0, ofpm_nw_src = nwsrcaddr, ofpm_nw_dst = nwdstaddr, ofpm_tp_src = 0, ofpm_tp_dst = 0 } fieldSetters = [setInPort, setDLSrc, setDLDst, setDLVLan, setDLVLanPriority, setDLType, setNWToS, setNWProto, setTPSrc, setTPDst, updateNWSrcWildcard, updateNWDstWildcard] setInPort = adjust 0 updateInPort 0 inPort setDLSrc = adjust 2 updateDLSrc nullEthAddr srcEthAddress setDLDst = adjust 3 updateDLDst nullEthAddr dstEthAddress setDLVLan = adjust 1 updateDLVLan 0 vLANID setDLVLanPriority = adjust 20 updateDLVLanPcp 0 vLANPriority setDLType = adjust 4 updateDLType 0 ethFrameType setNWToS = adjust 21 updateNWToS 0 ipTypeOfService setNWProto = adjust 5 updateNWProto 0 ipProtocol setTPSrc = adjust 6 updateTPSrc 0 srcTransportPort setTPDst = adjust 7 updateTPDst 0 dstTransportPort nwsrcaddr = fromIntegral $ ipAddressToWord32 $ addressPart srcIPAddress nwdstaddr = fromIntegral $ ipAddressToWord32 $ addressPart dstIPAddress modifyWildcardBits f m' = m' { ofpm_wildcards = f (ofpm_wildcards m') } updateNWSrcWildcard = let numIgnoredBits = 32 - (prefixLength srcIPAddress ) f wc = wc .|. shiftL (fromIntegral numIgnoredBits) 8 in modifyWildcardBits f updateNWDstWildcard = let numIgnoredBits = 32 - (prefixLength dstIPAddress ) f wc = wc .|. shiftL (fromIntegral numIgnoredBits) 14 in modifyWildcardBits f nullEthAddr = EthernetAddress 0 0 0 0 0 0 setWildcardBit i m' = m' { ofpm_wildcards = setBit (ofpm_wildcards m') i } clearWildcardBit i m' = m' { ofpm_wildcards = clearBit (ofpm_wildcards m') i } updateInPort v m' = m' { ofpm_in_port = v } updateDLSrc v m' = m' { ofpm_dl_src = v } updateDLDst v m' = m' { ofpm_dl_dst = v } updateDLVLan v m' = m' { ofpm_dl_vlan = v } updateDLVLanPcp v m' = m' { ofpm_dl_vlan_pcp = v } updateDLType v m' = m' { ofpm_dl_type = v } updateNWToS v m' = m' { ofpm_nw_tos = v } updateNWProto v m'= m' { ofpm_nw_proto = v } updateNWSrc v m' = m' { ofpm_nw_src = v } updateNWDst v m' = m' { ofpm_nw_dst = v } updateTPSrc v m' = m' { ofpm_tp_src = v } updateTPDst v m' = m' { ofpm_tp_dst = v } adjust wildcardIndex updater nullValue mv m' = case mv of Nothing -> setWildcardBit wildcardIndex $ updater nullValue m' Just v -> clearWildcardBit wildcardIndex $ updater v m' #endif ----------------------------------- -- Utilities ----------------------------------- getWord8s :: Int -> Get [Word8] getWord8s n = sequence $ replicate n getWord8 putWord8s :: [Word8] -> Put putWord8s bytes = sequence_ [putWord8 b | b <- bytes]