openflow-0.3.0: src/Network/Data/OpenFlow/MessagesBinary.hs
{-# 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]