{-# LANGUAGE CPP, DisambiguateRecordFields, RecordWildCards, NamedFieldPuns #-} {-# LANGUAGE BangPatterns #-} -- | 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 Network.Data.OpenFlow.MessagesBinary ( getCSMessage , putCSMessage , getSCMessage , putSCMessage ) where import Network.Data.Ethernet.EthernetAddress import Network.Data.Ethernet.EthernetFrame import Network.Data.IPv4.IPAddress import qualified Network.Data.OpenFlow.Messages as M import Network.Data.OpenFlow.Port import Network.Data.OpenFlow.Action import Network.Data.OpenFlow.Switch import Network.Data.OpenFlow.Match import Network.Data.OpenFlow.Packet import Network.Data.OpenFlow.FlowTable import Network.Data.OpenFlow.Statistics import Network.Data.OpenFlow.Error import Control.Applicative import Control.DeepSeq.Generics import Control.Monad (when) import Data.Monoid hiding ((<>), mconcat) import Data.Word import Data.Bits import Data.Binary import Data.Binary.Put import Data.Binary.Get import qualified Data.ByteString as B import Data.List as List import Data.Char (chr) import qualified Data.Map as Map import Data.Bimap (Bimap, (!), (!>)) import qualified Data.Bimap as Bimap import Data.Char (ord) instance Binary M.SCMessage where get = getSCMessage put = putSCMessage instance Binary M.CSMessage where put = putCSMessage get = getCSMessage type MessageTypeCode = Word8 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 -- | Parser for @SCMessage@s getSCMessage :: Get M.SCMessage getSCMessage = do hdr <- getHeader bdy <- getSCMessageBody (msgTransactionID hdr) (msgType hdr) (fromIntegral $ msgLength hdr) return bdy -- | Parser for @CSMessage@s getCSMessage :: Get M.CSMessage getCSMessage = do hdr <- getHeader snd <$> getCSMessageBody hdr -- | Unparser for @SCMessage@s putSCMessage :: M.SCMessage -> Put putSCMessage msg = case msg of M.SCHello xid -> putH xid ofptHello headerSize M.SCEchoRequest xid bytes -> putH xid ofptEchoRequest (headerSize + length bytes) <> putWord8s bytes M.SCEchoReply xid bytes -> putH xid ofptEchoReply (headerSize + length bytes) <> putWord8s bytes M.PacketIn xid pktInfo -> let bodyLen = packetInMessageBodyLen pktInfo in putH xid ofptPacketIn (headerSize + bodyLen) <> putPacketInRecord pktInfo M.Features xid features -> putH xid ofptFeaturesReply (headerSize + 24 + 48 * length (ports features)) <> putSwitchFeaturesRecord features M.Error xid err -> putH xid ofptError (headerSize + 2 + 2) <> putSwitchError err _ -> error ("serialization for message " ++ show msg ++ " is not yet supported.") where vid = ofpVersion putH xid tcode len = putHeader (OFPHeader vid tcode (fromIntegral len) xid) packetInMessageBodyLen :: PacketInfo -> Int packetInMessageBodyLen pktInfo = 10 + fromIntegral (packetLength pktInfo) putPacketInRecord :: PacketInfo -> Put putPacketInRecord (PacketInfo {..}) = putWord32be (maybe 0xffffffff id bufferID) <> (putWord16be $ fromIntegral packetLength ) <> putWord16be receivedOnPort <> (putWord8 $ reason2Code reasonSent) <> putWord8 0 {- Header -} type OpenFlowVersionID = Word8 ofpVersion :: OpenFlowVersionID ofpVersion = 0x01 -- | OpenFlow message header data OFPHeader = OFPHeader { msgVersion :: !OpenFlowVersionID , msgType :: !MessageTypeCode , msgLength :: !Word16 , msgTransactionID :: !M.TransactionID } deriving (Show,Eq) instance NFData OFPHeader headerSize :: Int headerSize = 8 -- | Unparser for OpenFlow message header putHeader :: OFPHeader -> Put putHeader (OFPHeader {..}) = putWord8 msgVersion <> putWord8 msgType <> putWord16be msgLength <> putWord32be msgTransactionID putHeaderInternal :: MessageTypeCode -> Word16 -> M.TransactionID -> Put putHeaderInternal !t !l !x = putWord8 ofpVersion <> putWord8 t <> putWord16be l <> putWord32be x {-# INLINE putHeaderInternal #-} -- | 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 {-# INLINE getHeader #-} -- Get SCMessage body {-# INLINE getSCMessageBody #-} getSCMessageBody :: M.TransactionID -> MessageTypeCode -> Int -> Get M.SCMessage getSCMessageBody !xid !msgType !len | msgType == ofptPacketIn = do packetInRecord <- getPacketInRecord len return (M.PacketIn xid packetInRecord) | msgType == ofptEchoRequest = do bytes <- getWord8s (len - headerSize) return (M.SCEchoRequest xid bytes) | msgType == ofptEchoReply = do bytes <- getWord8s (len - headerSize) return (M.SCEchoReply xid bytes) | msgType == ofptFeaturesReply = do switchFeaturesRecord <- getSwitchFeaturesRecord len return (M.Features xid switchFeaturesRecord) | msgType == ofptHello = return (M.SCHello xid ) | msgType == ofptPortStatus = do body <- getPortStatus return (M.PortStatus xid body) | msgType == ofptError = do body <- getSwitchError len return (M.Error xid body) | msgType == ofptFlowRemoved = do body <- getFlowRemovedRecord return (M.FlowRemoved xid body) | msgType == ofptBarrierReply = return $ M.BarrierReply xid | msgType == ofptStatsReply = do body <- getStatsReply len return (M.StatsReply xid body) | msgType == ofptQueueGetConfigReply = do qcReply <- getQueueConfigReply len return (M.QueueConfigReply xid qcReply) | otherwise = error ("Unrecognized message type: " ++ show msgType) getCSMessageBody :: OFPHeader -> Get (M.TransactionID, M.CSMessage) getCSMessageBody header@(OFPHeader {..}) = if msgType == ofptPacketOut then do packetOut <- getPacketOut len return (msgTransactionID, M.PacketOut msgTransactionID packetOut) else if msgType == ofptFlowMod then do fmod <- getFlowMod len return (msgTransactionID, M.FlowMod msgTransactionID fmod) else if msgType == ofptHello then return (msgTransactionID, M.CSHello msgTransactionID) else if msgType == ofptEchoRequest then do bytes <- getWord8s (len - headerSize) return (msgTransactionID, M.CSEchoRequest msgTransactionID bytes) else if msgType == ofptEchoReply then do bytes <- getWord8s (len - headerSize) return (msgTransactionID, M.CSEchoReply msgTransactionID bytes) else if msgType == ofptFeaturesRequest then return (msgTransactionID, M.FeaturesRequest msgTransactionID) else if msgType == ofptSetConfig then do _ <- getSetConfig return (msgTransactionID, M.SetConfig msgTransactionID) else if msgType == ofptVendor then do () <- getVendorMessage len return (msgTransactionID, M.Vendor msgTransactionID) else error ("Unrecognized message type with header: " ++ show header) where len = fromIntegral msgLength ----------------------- -- Queue Config parser ----------------------- getQueueConfigReply :: Int -> Get QueueConfigReply getQueueConfigReply len = do portID <- getWord16be skip 6 qs <- getQueues 16 [] return (PortQueueConfig portID qs) where getQueues pos acc = if pos < len then do (q, n) <- getQueue let pos' = pos + n pos' `seq` getQueues pos' (q:acc) else return acc getQueue = do qid <- getWord32be qdlen <- getWord16be skip 2 qprops <- getQueueProps qdlen 8 [] -- at byte 8 because of ofp_packet_queue header and len includes header (my guess). return (QueueConfig qid qprops, fromIntegral qdlen) where getQueueProps qdlen pos acc = if pos < qdlen then do (prop, propLen) <- getQueueProp let pos' = pos + propLen pos' `seq` getQueueProps qdlen pos' (prop : acc) else return acc getQueueProp = do propType <- getWord16be propLen <- getWord16be skip 4 when (propType /= ofpqtMinRate) (error ("Unexpected queue property type code " ++ show propType)) rate <- getWord16be skip 6 let rate' = if rate > 1000 then Disabled else Enabled rate return (MinRateQueue rate', propLen) ofpqtMinRate :: Word16 ofpqtMinRate = 1 ---------------------- -- Set Config parser ---------------------- getSetConfig :: Get (Word16, Word16) getSetConfig = do flags <- getWord16be missSendLen <- getWord16be return (flags, missSendLen) ------------------------------------------- -- Vendor parser ------------------------------------------- getVendorMessage :: Int -> Get () getVendorMessage r = do skip r return () ------------------------------------------- -- SWITCH FEATURES PARSER ------------------------------------------- putSwitchFeaturesRecord :: SwitchFeatures -> Put putSwitchFeaturesRecord (SwitchFeatures {..}) = putWord64be switchID <> (putWord32be $ fromIntegral packetBufferSize) <> (putWord8 $ fromIntegral numberFlowTables) <> (sequence_ $ replicate 3 (putWord8 0)) <> (putWord32be $ switchCapabilitiesBitVector capabilities) <> (putWord32be $ actionTypesBitVector supportedActions) <> mconcat [ putPhyPort p | p <- ports ] getSwitchFeaturesRecord :: Int -> Get SwitchFeatures 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 putPhyPort :: Port -> Put putPhyPort (Port {..}) = putWord16be portID <> putEthernetAddress portAddress <> (putWord8s $ take ofpMaxPortNameLen (map (fromIntegral . ord) portName ++ repeat 0)) <> (putWord32be $ portConfigsBitVector portConfig) <> (putWord32be $ portState2Code portLinkDown portSTPState) <> (putWord32be $ featuresBitVector $ maybe [] id portCurrentFeatures) <> (putWord32be $ featuresBitVector $ maybe [] id portAdvertisedFeatures) <> (putWord32be $ featuresBitVector $ maybe [] id portSupportedFeatures) <> (putWord32be $ featuresBitVector $ maybe [] id portPeerFeatures) getPhyPort :: Get Port getPhyPort = do port_no <- getWord16be 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 } ofpMaxPortNameLen :: Int ofpMaxPortNameLen = 16 featuresBitVector :: [PortFeature] -> Word32 featuresBitVector = foldl (\v f -> v .|. featureBitMask f) 0 featureBitMask :: PortFeature -> Word32 featureBitMask feat = case lookup feat featurePositions of Nothing -> error "unexpected port feature" Just i -> bit i decodePortFeatureSet :: Word32 -> Maybe [PortFeature] decodePortFeatureSet word | word == 0 = Nothing | otherwise = Just $ concat [ if word `testBit` position then [feat] else [] | (feat, position) <- featurePositions ] featurePositions :: [(PortFeature, Int)] 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, ofppsStpBlock, ofppsStpMask :: 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 portState2Code :: Bool -> SpanningTreePortState -> Word32 portState2Code isUp stpState = let b1 = if isUp then ofppsLinkDown else 0 b2 = case stpState of STPListening -> ofppsStpListen STPLearning -> ofppsStpLearn STPForwarding -> ofppsStpForward STPBlocking -> ofppsStpBlock in b1 .|. b2 bitMap2PortConfigAttributeSet :: Word32 -> [PortConfigAttribute] bitMap2PortConfigAttributeSet bmap = filter inBMap $ enumFrom $ toEnum 0 where inBMap attr = let mask = portAttribute2BitMask attr in mask .&. bmap == mask portConfigsBitVector :: [PortConfigAttribute] -> Word32 portConfigsBitVector = foldl (\v a -> v .|. portAttribute2BitMask a) 0 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 capList where inBMap attr = let mask = switchCapability2BitMask attr in mask .&. bmap == mask capList = [ HasFlowStats , HasTableStats , HasPortStats , SpanningTree , CanReassembleIPFragments , HasQueueStatistics , CanMatchIPAddressesInARPPackets ] switchCapabilitiesBitVector :: [SwitchCapability] -> Word32 switchCapabilitiesBitVector = foldl (\vector c -> vector .|. switchCapability2BitMask c) 0 switchCapability2BitMask :: SwitchCapability -> Word32 switchCapability2BitMask HasFlowStats = shiftL 1 0 switchCapability2BitMask HasTableStats = shiftL 1 1 switchCapability2BitMask HasPortStats = shiftL 1 2 switchCapability2BitMask SpanningTree = shiftL 1 3 switchCapability2BitMask CanReassembleIPFragments = shiftL 1 5 switchCapability2BitMask HasQueueStatistics = shiftL 1 6 switchCapability2BitMask CanMatchIPAddressesInARPPackets = shiftL 1 7 switchCapability2BitMask MayTransmitOverMultiplePhysicalInterfaces = error "No encoding defined for MayTransmitOverMultiplePhysicalInterfaces" bitMap2SwitchActionSet :: Word32 -> [ActionType] bitMap2SwitchActionSet bmap = filter inBMap $ enumFrom $ toEnum 0 where inBMap attr = let mask = actionType2BitMask attr in mask .&. bmap == mask actionTypesBitVector :: [ActionType] -> Word32 actionTypesBitVector = foldl (\v a -> v .|. actionType2BitMask a) 0 code2ActionType :: Word16 -> ActionType code2ActionType !code = case code of 0 -> OutputToPortType 1 -> SetVlanVIDType 2 -> SetVlanPriorityType 3 -> StripVlanHeaderType 4 -> SetEthSrcAddrType 5 -> SetEthDstAddrType 6 -> SetIPSrcAddrType 7 -> SetIPDstAddrType 8 -> SetIPTypeOfServiceType 9 -> SetTransportSrcPortType 10 -> SetTransportDstPortType 11 -> EnqueueType 0xffff -> VendorActionType _ -> error "Unknown action type code" {-# INLINE code2ActionType #-} actionType2Code :: ActionType -> Word16 actionType2Code OutputToPortType = 0 actionType2Code SetVlanVIDType = 1 actionType2Code SetVlanPriorityType = 2 actionType2Code StripVlanHeaderType = 3 actionType2Code SetEthSrcAddrType = 4 actionType2Code SetEthDstAddrType = 5 actionType2Code SetIPSrcAddrType = 6 actionType2Code SetIPDstAddrType = 7 actionType2Code SetIPTypeOfServiceType = 8 actionType2Code SetTransportSrcPortType = 9 actionType2Code SetTransportDstPortType = 10 actionType2Code EnqueueType = 11 actionType2Code VendorActionType = 0xffff {-# INLINE actionType2Code #-} actionType2BitMask :: ActionType -> Word32 actionType2BitMask = shiftL 1 . fromIntegral . actionType2Code ------------------------------------------ -- Packet In Parser ------------------------------------------ {-# INLINE getPacketInRecord #-} getPacketInRecord :: Int -> Get PacketInfo getPacketInRecord len = do bufID <- getWord32be totalLen <- getWord16be in_port <- getWord16be reasonCode <- getWord8 skip 1 let !reason = code2Reason reasonCode (!hdr, bdy) <- lookAhead getEthernetFrame rawBytes' <- getByteString $ fromIntegral data_len return $ PacketInfo { bufferID = if bufID == 0xffffffff then Nothing else Just bufID , packetLength = fromIntegral totalLen , receivedOnPort = in_port , reasonSent = reason , enclosedFrame = (hdr,bdy) , rawBytes = rawBytes' } where data_offset = 18 -- 8 + 4 + 2 + 2 + 1 + 1 data_len = len - data_offset {-# INLINE code2Reason #-} code2Reason :: Word8 -> PacketInReason code2Reason !code | code == 0 = NotMatched | code == 1 = ExplicitSend | otherwise = error ("Received unknown packet-in reason code: " ++ show code ++ ".") {-# INLINE reason2Code #-} reason2Code :: PacketInReason -> Word8 reason2Code NotMatched = 0 reason2Code ExplicitSend = 1 ------------------------------------------ -- Port Status parser ------------------------------------------ getPortStatus :: Get PortStatus getPortStatus = do reasonCode <- getWord8 skip 7 portDesc <- getPhyPort return $ (code2PortStatusUpdateReason reasonCode, portDesc) code2PortStatusUpdateReason :: (Eq a, Num a, Show a) => a -> PortStatusUpdateReason code2PortStatusUpdateReason code | code == 0 = PortAdded | code == 1 = PortDeleted | code == 2 = PortModified | otherwise = 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) putSwitchError :: SwitchError -> Put putSwitchError (BadRequest VendorNotSupported []) = putWord16be 1 <> putWord16be 3 putSwitchError err = error ("Serialization for error " ++ show err ++ " not yet supported.") code2ErrorType :: Word16 -> Word16 -> [Word8] -> SwitchError 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" | otherwise = error "Unknown error type code" helloErrorCodesMap :: Bimap Word16 HelloFailure helloErrorCodesMap = Bimap.fromList [ (0, IncompatibleVersions) , (1 , HelloPermissionsError) ] requestErrorCodeMap :: Bimap Word16 RequestError requestErrorCodeMap = Bimap.fromList [ (0, VersionNotSupported), (1 , MessageTypeNotSupported), (2 , StatsRequestTypeNotSupported), (3 , VendorNotSupported), (4, VendorSubtypeNotSupported) , (5 , RequestPermissionsError) , (6 , BadRequestLength) , (7, BufferEmpty) , (8, UnknownBuffer) ] actionErrorCodeMap :: Bimap Word16 ActionError actionErrorCodeMap = Bimap.fromList [ (0, UnknownActionType), (1, BadActionLength), (2, UnknownVendorID), (3, UnknownActionTypeForVendor), (4, BadOutPort), (5, BadActionArgument) , (6, ActionPermissionsError) , (7, TooManyActions) , (8, InvalidQueue) ] flowModErrorCodeMap :: Bimap Word16 FlowModError flowModErrorCodeMap = Bimap.fromList [ (0, TablesFull) , (1, OverlappingFlow) , (2, FlowModPermissionsError) , (3, EmergencyModHasTimeouts) , (4, BadCommand) , (5, UnsupportedActionList) ] ------------------------------------------ -- FlowRemoved parser ------------------------------------------ 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 $ FlowRemovedRecord m cookie p (code2FlowRemovalReason rcode) (fromIntegral dur) (fromIntegral dur_nsec) (fromIntegral idle_timeout) (fromIntegral pktCount) (fromIntegral byteCount) flowRemovalReason2CodeBijection :: Bimap FlowRemovalReason Word8 flowRemovalReason2CodeBijection = Bimap.fromList [(IdleTimerExpired, 0), (HardTimerExpired, 1), (DeletedByController, 2) ] code2FlowRemovalReason :: Word8 -> FlowRemovalReason 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 statsType == ofpstQueue then do queueStats <- getQueueStatsReplies bodyLen return (QueueStatsReply moreFlag queueStats) else error ("unhandled stats reply message with type: " ++ show statsType) 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 }) 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 , datapathDesc = dp } ) 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 ] _ <- 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 !dur_nanosec <- getWord32be !priority <- getWord16be !idle_to <- getWord16be !hard_to <- getWord16be skip 6 !cookie <- getWord64be !packet_count <- getWord64be !byte_count <- getWord64be actions <- getActionsOfSize (fromIntegral len - flowStatsReplySize) let !stats = FlowStats { flowStatsTableID = tid, flowStatsMatch = match, flowStatsDurationSeconds = fromIntegral dur_sec, flowStatsDurationNanoseconds = fromIntegral dur_nanosec, flowStatsPriority = priority, flowStatsIdleTimeout = fromIntegral idle_to, flowStatsHardTimeout = fromIntegral hard_to, flowStatsCookie = cookie, flowStatsPacketCount = fromIntegral packet_count, flowStatsByteCount = fromIntegral byte_count, flowStatsActions = actions } return (stats, fromIntegral len) where flowStatsReplySize = 88 getActionsOfSize :: Int -> Get [Action] getActionsOfSize n | n > 0 = do a <- getAction as <- getActionsOfSize (n - actionSizeInBytes a) return (a : as) | n == 0 = return [] | otherwise = error "bad number of actions or bad action size" 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 | otherwise = error "Unknown pseudo-port code" 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) getActionForType SetIPTypeOfServiceType _ = do tos <- getWord8 skip 3 return (SetIPToS tos) getActionForType SetTransportSrcPortType _ = do port <- getWord16be return (SetTransportSrcPort port) getActionForType SetTransportDstPortType _ = do port <- getWord16be return (SetTransportDstPort port) 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) getAggregateStatsReplies :: Int -> Get AggregateFlowStats getAggregateStatsReplies _ = 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 ---------------------------------------------- putCSMessage :: M.CSMessage -> Put putCSMessage !msg = case msg of M.FlowMod xid fmod -> putFlowModMain xid fmod M.PacketOut xid packetOut -> putSendPacket xid packetOut M.CSHello xid -> putH xid ofptHello headerSize M.CSEchoRequest xid bytes -> putH xid ofptEchoRequest (headerSize + length bytes) <> putWord8s bytes M.CSEchoReply xid bytes -> putEchoReply xid bytes M.FeaturesRequest xid -> putFeatureRequest xid M.PortMod xid portModRecord -> putH xid ofptPortMod portModLength <> putPortMod portModRecord M.BarrierRequest xid -> putBarrierRequest xid M.StatsRequest xid request -> putH xid ofptStatsRequest (statsRequestSize request) <> putStatsRequestBody request M.GetQueueConfig xid request -> putH xid ofptQueueGetConfigRequest 12 <> putQueueConfigRequest request M.ExtQueueModify xid p qCfgs -> putExtQueueModify xid p qCfgs M.ExtQueueDelete xid p qCfgs -> putExtQueueDelete xid p qCfgs _ -> error ("Serialization of message " ++ show msg ++ " not yet supported.") where vid = ofpVersion putH :: M.TransactionID -> MessageTypeCode -> Int -> Put putH xid tcode len = putHeader (OFPHeader vid tcode (fromIntegral len) xid) {-# INLINE putCSMessage #-} putBarrierRequest :: M.TransactionID -> Put putBarrierRequest xid = putHeaderInternal ofptBarrierRequest (fromIntegral headerSize) xid putFeatureRequest :: M.TransactionID -> Put putFeatureRequest xid = putHeaderInternal ofptFeaturesRequest (fromIntegral headerSize) xid putEchoReply :: M.TransactionID -> [Word8] -> Put putEchoReply xid bytes = putHeaderInternal ofptEchoReply (fromIntegral (headerSize + length bytes)) xid <> putWord8s bytes putQueueConfigRequest :: QueueConfigRequest -> Put putQueueConfigRequest (QueueConfigRequest portID) = putWord16be portID <> putWord16be 0 --padding putExtQueueModify :: M.TransactionID -> PortID -> [QueueConfig] -> Put putExtQueueModify xid p qCfgs = putHeaderInternal ofptVendor (fromIntegral (headerSize + 16 + sum (map lenQueueConfig qCfgs))) xid <> putWord32be 0x000026e1 <> -- OPENFLOW_VENDOR_ID putWord32be 0 <> -- OFP_EXT_QUEUE_MODIFY putWord16be p <> putWord32be 0 <> putWord16be 0 <> mconcat (map putQueueConfig qCfgs) putExtQueueDelete :: M.TransactionID -> PortID -> [QueueConfig] -> Put putExtQueueDelete xid p qCfgs = putHeaderInternal ofptVendor (fromIntegral (headerSize + 16 + sum (map lenQueueConfig qCfgs)) ) xid <> putWord32be 0x000026e1 <> -- OPENFLOW_VENDOR_ID putWord32be 1 <> -- OFP_EXT_QUEUE_DELETE putWord16be p <> putWord32be 0 <> putWord16be 0 <> mconcat (map putQueueConfig qCfgs) -- struct ofp_packet_queue putQueueConfig :: QueueConfig -> Put putQueueConfig (QueueConfig qid props) = putWord32be qid <> putWord16be (fromIntegral (8 + sum (map lenQueueProp props))) <> putWord16be 0 <> -- padding mapM_ putQueueProp props -- struct ofp_queue_prop_min_rate putQueueProp :: QueueProperty -> Put putQueueProp (MinRateQueue (Enabled rate)) = putWord16be 1 <> -- OFPQT_MIN_RATE putWord16be 16 <> -- length putWord32be 0 <> -- padding putWord16be rate <> putWord32be 0 <> -- padding putWord16be 0 --padding putQueueProp prop = error ("Serialization of queue property " ++ show prop ++ " not yet supported.") lenQueueConfig :: QueueConfig -> Int lenQueueConfig (QueueConfig _ props) = 8 + sum (map lenQueueProp props) lenQueueProp :: QueueProperty -> Int lenQueueProp (MinRateQueue _) = 16 ------------------------------------------ -- Unparser for packet out message ------------------------------------------ sendPacketSizeInBytes :: PacketOut -> Int sendPacketSizeInBytes (!PacketOutRecord bufferIDData _ actions) = 16 {- 16 == headerSize + 4 + 2 + 2 -} + actionSequenceSizeInBytes actions + case bufferIDData of { Left _ -> 0 ; Right xs -> fromIntegral (B.length xs) } putSendPacket_ :: PacketOut -> Put putSendPacket_ (PacketOutRecord {..}) = (putWord32be $ either id (const (-1)) bufferIDData) <> putWord16be (maybe ofppNone id packetInPort) <> putWord16be (fromIntegral actionArraySize) <> (putActions $ actionSequenceToList packetActions) <> (either (const $ return ()) putByteString bufferIDData) where actionArraySize = actionSequenceSizeInBytes packetActions {-# INLINE putSendPacket #-} putSendPacket :: M.TransactionID -> PacketOut -> Put putSendPacket xid pkt = putHeaderInternal ofptPacketOut (fromIntegral $ sendPacketSizeInBytes pkt) xid <> putSendPacket_ pkt getPacketOut :: Int -> Get PacketOut getPacketOut len = do bufID' <- getWord32be port' <- getWord16be actionArraySize' <- getWord16be actions <- getActionsOfSize (fromIntegral actionArraySize') packetData <- if bufID' == -1 then let bytesOfData = len - headerSize - 4 - 2 - 2 - fromIntegral actionArraySize' in getByteString (fromIntegral bytesOfData) else return B.empty return $ PacketOutRecord { bufferIDData = if bufID' == -1 then Right packetData else Left bufID' , packetInPort = if port' == ofppNone then Nothing else Just port' , packetActions = ActionSequence (error "unknown size") actions } ------------------------------------------ -- Unparser for flow mod message ------------------------------------------ flowModSizeInBytes' :: ActionSequence -> Int flowModSizeInBytes' !actions = 72 + actionSequenceSizeInBytes actions -- 72 = headerSize + matchSize + 24 {-# INLINE flowModSizeInBytes' #-} data FlowModRecordInternal = FlowModRecordInternal { command' :: !FlowModType , match' :: !Match , actions' :: !([Action]) , priority' :: !Priority , idleTimeOut' :: !(Maybe TimeOut) , hardTimeOut' :: !(Maybe TimeOut) , flags' :: !([FlowModFlag]) , bufferID' :: !(Maybe BufferID) , outPort' :: !(Maybe PseudoPort) , cookie' :: !Cookie } deriving (Eq,Show) -- | Specification: @ofp_flow_mod_command@. data FlowModType = FlowAddType | FlowModifyType | FlowModifyStrictType | FlowDeleteType | FlowDeleteStrictType deriving (Show,Eq,Ord) -- | A set of flow mod attributes can be added to a flow modification command. data FlowModFlag = SendFlowRemoved | CheckOverlap | Emergency deriving (Show,Eq,Ord,Enum) {-# INLINE putFlowModMain #-} putFlowModMain :: M.TransactionID -> FlowMod -> Put putFlowModMain !xid !fmod = case fmod of (DeleteFlows {..}) -> putHeaderInternal ofptFlowMod (fromIntegral $ flowModSizeInBytes' mempty) xid <> putMatch match <> putWord64be 0 <> putWord16be ofpfcDelete <> putWord32be 0 <> putWord16be 0 <> putWord32be (-1) <> (putWord16be $ maybe ofppNone fakePort2Code outPort) <> putWord16be 0 (DeleteFlowStrict {..}) -> putHeaderInternal ofptFlowMod (fromIntegral $ flowModSizeInBytes' mempty) xid <> putMatch match <> putWord64be 0 <> (putWord16be $ flowModTypeToCode FlowDeleteStrictType) <> putWord32be 0 <> putWord16be priority <> putWord32be (-1) <> (putWord16be $ maybe ofppNone fakePort2Code outPort) <> putWord16be 0 (AddFlow !match !priority !actions !cookie !idleTimeOut !hardTimeOut !notifyWhenRemoved !applyToPacket !overlapAllowed) -> putHeaderInternal ofptFlowMod (fromIntegral $ flowModSizeInBytes' actions) xid <> putMatch match <> putWord64be cookie <> putWord16be ofpfcAdd <> (putWord16be $ timeOutToCode idleTimeOut) <> (putWord16be $ timeOutToCode hardTimeOut) <> putWord16be priority <> (putWord32be $ maybe (-1) id applyToPacket) <> putWord16be ofppNone <> (putWord16be $ let overlapFlag = if overlapAllowed then 0 else 2 removeFlag = if notifyWhenRemoved then 1 else 0 in overlapFlag .|. removeFlag) <> (putActions $ actionSequenceToList actions) (AddEmergencyFlow {..}) -> putHeaderInternal ofptFlowMod (fromIntegral $ flowModSizeInBytes' actions) xid <> putMatch match <> putWord64be cookie <> putWord16be ofpfcAdd <> putWord32be 0 <> putWord16be priority <> putWord32be (-1) <> putWord16be ofppNone <> (putWord16be $ let emergencyFlag = 4 overlapFlag = if overlapAllowed then 0 else 2 in emergencyFlag .|. overlapFlag) <> (putActions $ actionSequenceToList actions) (ModifyFlows {..}) -> putHeaderInternal ofptFlowMod (fromIntegral $ flowModSizeInBytes' newActions) xid <> putMatch match <> putWord64be ifMissingCookie <> (putWord16be $ flowModTypeToCode FlowModifyType) <> (putWord16be $ timeOutToCode ifMissingIdleTimeOut) <> (putWord16be $ timeOutToCode ifMissingHardTimeOut) <> putWord16be ifMissingPriority <> putWord32be (-1) <> putWord16be ofppNone <> (putWord16be $ let overlapFlag = if ifMissingOverlapAllowed then 0 else 2 removeFlag = if ifMissingNotifyWhenRemoved then 1 else 0 in overlapFlag .|. removeFlag) <> (putActions $ actionSequenceToList newActions) (ModifyFlowStrict {..}) -> putHeaderInternal ofptFlowMod (fromIntegral $ flowModSizeInBytes' newActions) xid <> putMatch match <> putWord64be ifMissingCookie <> (putWord16be $ flowModTypeToCode FlowModifyStrictType) <> (putWord16be $ timeOutToCode ifMissingIdleTimeOut) <> (putWord16be $ timeOutToCode ifMissingHardTimeOut) <> putWord16be priority <> putWord32be (-1) <> putWord16be ofppNone <> (putWord16be $ let overlapFlag = if ifMissingOverlapAllowed then 0 else 2 removeFlag = if ifMissingNotifyWhenRemoved then 1 else 0 in overlapFlag .|. removeFlag) <> (putActions $ actionSequenceToList newActions) (<>) :: Put -> Put -> Put x <> y = x >> y mconcat :: [Put] -> Put mconcat = sequence_ putActions :: [Action] -> Put putActions = mapM_ putAction getBufferID :: Get (Maybe BufferID) getBufferID = do w <- getWord32be if w == -1 then return Nothing else return (Just w) getOutPort :: Get (Maybe PseudoPort) getOutPort = do w <- getWord16be if w == ofppNone then return Nothing else return (Just (code2FakePort w)) getFlowModInternal :: Int -> Get FlowModRecordInternal getFlowModInternal len = do match <- getMatch cookie <- getWord64be modType <- getFlowModType idleTimeOut <- getTimeOutFromCode hardTimeOut <- getTimeOutFromCode priority <- getWord16be mBufferID <- getBufferID outPort <- getOutPort flags <- getFlowModFlags let bytesInActionList = len - 72 actions <- getActionsOfSize (fromIntegral bytesInActionList) return $ FlowModRecordInternal { command' = modType , match' = match , actions' = actions , priority' = priority , idleTimeOut' = idleTimeOut , hardTimeOut' = hardTimeOut , flags' = flags , bufferID' = mBufferID , outPort' = outPort , cookie' = cookie } getFlowMod :: Int -> Get FlowMod getFlowMod len = getFlowModInternal len >>= return . flowModInternal2FlowMod --fromJust2 :: String -> Maybe a -> a --fromJust2 s Nothing = error s --fromJust2 _ (Just a) = a fromJust :: Maybe a -> a fromJust Nothing = error "MessagesBinary.fromJust" fromJust (Just a) = a flowModInternal2FlowMod :: FlowModRecordInternal -> FlowMod flowModInternal2FlowMod (FlowModRecordInternal {..}) = case command' of FlowDeleteType -> DeleteFlows { match = match', outPort = outPort' } FlowDeleteStrictType -> DeleteFlowStrict { match = match', outPort = outPort', priority = priority' } FlowAddType -> if elem Emergency flags' then AddEmergencyFlow { match = match' , priority = priority' , actions = ActionSequence (error "size unknown") actions' , cookie = cookie' , overlapAllowed = elem CheckOverlap flags' } else AddFlow { match = match' , priority = priority' , actions = ActionSequence (error "size unknown") actions' , cookie = cookie' , idleTimeOut = fromJust idleTimeOut' , hardTimeOut = fromJust hardTimeOut' , notifyWhenRemoved = elem SendFlowRemoved flags' , applyToPacket = bufferID' , overlapAllowed = elem CheckOverlap flags' } FlowModifyType -> ModifyFlows { match = match' , newActions = ActionSequence (error "size unknown") actions' , ifMissingPriority = priority' , ifMissingCookie = cookie' , ifMissingIdleTimeOut = fromJust idleTimeOut' , ifMissingHardTimeOut = fromJust hardTimeOut' , ifMissingOverlapAllowed = CheckOverlap `elem` flags' , ifMissingNotifyWhenRemoved = SendFlowRemoved `elem` flags' } FlowModifyStrictType -> ModifyFlowStrict { match = match' , newActions = ActionSequence (error "size unknown") actions' , priority = priority' , ifMissingCookie = cookie' , ifMissingIdleTimeOut = fromJust idleTimeOut' , ifMissingHardTimeOut = fromJust hardTimeOut' , ifMissingOverlapAllowed = CheckOverlap `elem` flags' , ifMissingNotifyWhenRemoved = SendFlowRemoved `elem` flags' } timeOutToCode :: TimeOut -> Word16 timeOutToCode Permanent = 0 timeOutToCode (ExpireAfter t) = t getTimeOutFromCode :: Get (Maybe TimeOut) getTimeOutFromCode = do code <- getWord16be if code == 0 then return Nothing else return (Just (ExpireAfter code)) flowModFlagToBitMaskBijection :: [(FlowModFlag,Word16)] flowModFlagToBitMaskBijection = [(SendFlowRemoved, shiftL 1 0), (CheckOverlap, shiftL 1 1), (Emergency, shiftL 1 2) ] bitMap2FlagSet :: Word16 -> [FlowModFlag] bitMap2FlagSet w = [ flag | (flag,mask) <- flowModFlagToBitMaskBijection, mask .&. w /= 0 ] getFlowModFlags :: Get [FlowModFlag] getFlowModFlags = do w <- getWord16be return (bitMap2FlagSet w) 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) ] getFlowModType :: Get FlowModType getFlowModType = do code <- getWord16be return (flowModTypeBimap !> code) flowModTypeToCode :: FlowModType -> Word16 flowModTypeToCode !FlowAddType = ofpfcAdd flowModTypeToCode !FlowModifyType = ofpfcModify flowModTypeToCode !FlowModifyStrictType = ofpfcModifyStrict flowModTypeToCode !FlowDeleteType = ofpfcDelete flowModTypeToCode !FlowDeleteStrictType = ofpfcDeleteStrict putAction :: Action -> Put putAction !act = case act of (SendOutPort !port) -> putWord32be 8 >> -- replaces putWord16be 0 >> putWord16be 8 putPseudoPort port (SetVlanVID vlanid) -> putWord16be 1 >> putWord16be 8 >> putWord16be vlanid >> putWord16be 0 (SetVlanPriority priority) -> putWord16be 2 >> putWord16be 8 >> putWord8 priority >> putWord8 0 >> putWord8 0 >> putWord8 0 (StripVlanHeader) -> putWord16be 3 >> putWord16be 8 >> putWord32be 0 (SetEthSrcAddr addr) -> putWord16be 4 >> putWord16be 16 >> putEthernetAddress addr >> sequence_ (replicate 6 (putWord8 0)) (SetEthDstAddr addr) -> putWord16be 5 >> putWord16be 16 >> putEthernetAddress addr >> sequence_ (replicate 6 (putWord8 0)) (SetIPSrcAddr addr) -> putWord16be 6 >> putWord16be 8 >> putWord32be (ipAddressToWord32 addr) (SetIPDstAddr addr) -> putWord16be 7 >> putWord16be 8 >> putWord32be (ipAddressToWord32 addr) (SetIPToS tos) -> putWord16be 8 >> putWord16be 8 >> putWord8 tos >> sequence_ (replicate 3 (putWord8 0)) (SetTransportSrcPort port) -> putWord16be 9 >> putWord16be 8 >> putWord16be port >> putWord16be 0 (SetTransportDstPort port) -> putWord16be 10 >> putWord16be 8 >> putWord16be port >> putWord16be 0 (Enqueue port qid) -> putWord16be 11 >> putWord16be 16 >> putWord16be port >> sequence_ (replicate 6 (putWord8 0)) >> putWord32be qid (VendorAction vendorID 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 putWord16be 0xffff >> putWord16be (fromIntegral l) >> putWord32be vendorID >> mapM_ putWord8 bytes putPseudoPort :: PseudoPort -> Put putPseudoPort (PhysicalPort !pid) = putWord16be pid >> putWord16be 0 putPseudoPort (ToController !maxLen) = putWord16be ofppController >> putWord16be maxLen putPseudoPort !port = 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 actionSizeInBytes (!SetIPToS _) = 8 actionSizeInBytes (!SetTransportSrcPort _) = 8 actionSizeInBytes (!SetTransportDstPort _) = 8 actionSizeInBytes (!Enqueue _ _) = 16 actionSizeInBytes (!VendorAction _ bytes) = let l = length bytes + 8 -- + 2 + 2 + 4 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 {-# INLINE actionSizeInBytes #-} ------------------------------------------ -- Port mod unparser ------------------------------------------ portModLength :: Int portModLength = 32 putPortMod :: PortMod -> Put putPortMod (PortModRecord {..} ) = putWord16be portNumber <> putEthernetAddress hwAddr <> putConfigBitMap <> putMaskBitMap <> putAdvertiseBitMap <> putPad where putConfigBitMap = putWord32be (portAttributeSet2BitMask onAttrs) putMaskBitMap = putWord32be (portAttributeSet2BitMask attrsChanging) 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 statsRequestSize (PortStatsRequest _) = headerSize + 2 + 2 + 2 + 6 statsRequestSize (DescriptionRequest) = headerSize + 2 + 2 statsRequestSize req = error ("Size of " ++ show req ++ " not yet implemented.") putStatsRequestBody :: StatsRequest -> Put putStatsRequestBody (FlowStatsRequest match tableQuery mPort) = putWord16be ofpstFlow >> putWord16be 0 >> putMatch match >> putWord8 (tableQueryToCode tableQuery) >> putWord8 0 >> (putWord16be $ maybe ofppNone fakePort2Code mPort) putStatsRequestBody (AggregateFlowStatsRequest match tableQuery mPort) = putWord16be ofpstAggregate >> putWord16be 0 >> putMatch match >> putWord8 (tableQueryToCode tableQuery) >> putWord8 0 >> (putWord16be $ maybe ofppNone fakePort2Code mPort) putStatsRequestBody TableStatsRequest = putWord16be ofpstTable >> putWord16be 0 putStatsRequestBody DescriptionRequest = putWord16be ofpstDesc >> putWord16be 0 putStatsRequestBody (QueueStatsRequest portQuery queueQuery) = putWord16be ofpstQueue >> putWord16be 0 >> putWord16be (queryToPortNumber portQuery) >> putWord16be 0 >> putWord32be (queryToQueueID queueQuery) putStatsRequestBody (PortStatsRequest query) = 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 -- Not yet used: ofppMax :: Word16 -- ofppMax = 0xff00 ofppInPort, ofppTable, ofppNormal, ofppFlood, ofppAll, ofppController, ofppNone :: Word16 ofppInPort = 0xfff8 ofppTable = 0xfff9 ofppNormal = 0xfffa ofppFlood = 0xfffb ofppAll = 0xfffc ofppController = 0xfffd -- Not yet used: ofppLocal = 0xfffe ofppNone = 0xffff fakePort2Code :: PseudoPort -> Word16 fakePort2Code Flood = ofppFlood fakePort2Code (PhysicalPort portID) = portID fakePort2Code InPort = ofppInPort fakePort2Code AllPhysicalPorts = ofppAll fakePort2Code (ToController _) = ofppController fakePort2Code NormalSwitching = ofppNormal fakePort2Code WithTable = ofppTable code2FakePort :: Word16 -> PseudoPort code2FakePort w | w <= 0xff00 = PhysicalPort w | w == ofppInPort = InPort | w == ofppFlood = Flood | w == ofppAll = AllPhysicalPorts | w == ofppController = ToController 0 | w == ofppNormal = NormalSwitching | w == ofppTable = WithTable | otherwise = error ("unknown pseudo port number: " ++ show w) tableQueryToCode :: TableQuery -> Word8 tableQueryToCode AllTables = 0xff tableQueryToCode EmergencyTable = 0xfe tableQueryToCode (Table t) = t ofpstDesc, ofpstFlow, ofpstAggregate, ofpstTable, ofpstPort, ofpstQueue :: Word16 ofpstDesc = 0 ofpstFlow = 1 ofpstAggregate = 2 ofpstTable = 3 ofpstPort = 4 ofpstQueue = 5 -- Not yet used: ofpstVendor = 0xffff --------------------------------------------- -- Parser and Unparser for Match --------------------------------------------- matchSize :: Int matchSize = 40 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 (Match inPort (MatchHeader {..}) (MatchBody {..})) = putWord32be wildcards >> (putWord16be $ maybe 0 id inPort) >> (putEthernetAddress $ maybe nullEthAddr id srcEthAddress ) >> (putEthernetAddress $ maybe nullEthAddr id dstEthAddress ) >> (putWord16be $ maybe 0 id vLANID ) >> (putWord8 $ maybe 0 id vLANPriority ) >> putWord8 0 -- padding >> (putWord16be $ maybe 0 id ethFrameType) >> (putWord8 $ maybe 0 id ipTypeOfService ) >> (putWord8 $ maybe 0 id matchIPProtocol ) >> putWord16be 0 -- padding >> (putWord32be $ ipAddressToWord32 $ addressPart srcIPAddress ) >> (putWord32be $ ipAddressToWord32 $ addressPart dstIPAddress ) >> (putWord16be $ maybe 0 id srcTransportPort ) >> (putWord16be $ maybe 0 id dstTransportPort ) where nullEthAddr = ethernetAddress64 0 wildcards = shiftL (fromIntegral numIgnoredBitsSrc) 8 .|. shiftL (fromIntegral numIgnoredBitsDst) 14 .|. (maybe (flip setBit 0) (const id) inPort $ maybe (flip setBit 1) (const id) vLANID $ maybe (flip setBit 2) (const id) srcEthAddress $ maybe (flip setBit 3) (const id) dstEthAddress $ maybe (flip setBit 4) (const id) ethFrameType $ maybe (flip setBit 5) (const id) matchIPProtocol $ maybe (flip setBit 6) (const id) srcTransportPort $ maybe (flip setBit 7) (const id) dstTransportPort $ maybe (flip setBit 20) (const id) vLANPriority $ maybe (flip setBit 21) (const id) ipTypeOfService $ 0 ) numIgnoredBitsSrc = 32 - (prefixLength srcIPAddress) numIgnoredBitsDst = 32 - (prefixLength dstIPAddress) data OFPMatch = OFPMatch { ofpm_wildcards :: !Word32, ofpm_in_port :: !Word16, ofpm_dl_src, ofpm_dl_dst :: !EthernetAddress, ofpm_dl_vlan :: !Word16, ofpm_dl_vlan_pcp :: !Word8, ofpm_dl_type :: !Word16, ofpm_nw_tos :: !Word8, 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) (MatchHeader (getField 2 ofpm_dl_src) (getField 3 ofpm_dl_dst) (getField 1 ofpm_dl_vlan) (getField 20 ofpm_dl_vlan_pcp) (getField 4 ofpm_dl_type)) (MatchBody (getField 21 ofpm_nw_tos) (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 :: Int -> (OFPMatch -> a) -> Maybe a 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 ----------------------------------- -- Utilities ----------------------------------- getWord8s :: Int -> Get [Word8] getWord8s n = B.unpack <$> getByteString n putWord8s :: [Word8] -> Put putWord8s bytes = sequence_ [putWord8 b | b <- bytes]