{-# LANGUAGE CPP, DisambiguateRecordFields, RecordWildCards, NamedFieldPuns #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | 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 Prelude hiding (mconcat) 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.Monad (when) 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) import Control.DeepSeq (NFData) import GHC.Generics (Generic) 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,Generic,NFData) 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,Generic,NFData) -- | Specification: @ofp_flow_mod_command@. data FlowModType = FlowAddType | FlowModifyType | FlowModifyStrictType | FlowDeleteType | FlowDeleteStrictType deriving (Show,Eq,Ord,Generic,NFData) -- | A set of flow mod attributes can be added to a flow modification command. data FlowModFlag = SendFlowRemoved | CheckOverlap | Emergency deriving (Show,Eq,Ord,Enum,Generic,NFData) {-# 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,Generic,NFData) 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]