module Nettle.OpenFlow.MessagesBinary (
getHeader
, getSCMessage
, getSCMessageBody
, putSCMessage
, getCSMessage
, getCSMessageBody
, putCSMessage
, OFPHeader(..)
) where
import Nettle.Ethernet.EthernetAddress
import Nettle.Ethernet.EthernetFrame
import Nettle.IPv4.IPAddress
import Nettle.IPv4.IPPacket
import qualified Nettle.OpenFlow.Messages as M
import Nettle.OpenFlow.Port
import Nettle.OpenFlow.Action
import Nettle.OpenFlow.Switch
import Nettle.OpenFlow.Match
import Nettle.OpenFlow.Packet
import Nettle.OpenFlow.FlowTable
import qualified Nettle.OpenFlow.FlowTable as FlowTable
import Nettle.OpenFlow.Statistics
import Nettle.OpenFlow.Error
import Control.Monad (when)
import Control.Exception
import Data.Word
import Data.Bits
import Nettle.OpenFlow.StrictPut
import Data.Binary.Strict.Get
import qualified Data.ByteString as B
import Data.Maybe (fromJust, isJust)
import Data.List as List
import Data.Char (chr)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Bimap (Bimap, (!), (!>))
import qualified Data.Bimap as Bimap
import System.IO
import Control.Concurrent (yield)
import Data.IORef
import Data.Char (ord)
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
getSCMessage :: Get (M.TransactionID, M.SCMessage)
getSCMessage = do hdr <- getHeader
getSCMessageBody hdr
getCSMessage :: Get (M.TransactionID, M.CSMessage)
getCSMessage = do hdr <- getHeader
getCSMessageBody hdr
putSCMessage :: (M.TransactionID, M.SCMessage) -> Put
putSCMessage (xid, msg) =
case msg of
M.SCHello -> putH ofptHello headerSize
M.SCEchoRequest bytes -> do putH ofptEchoRequest (headerSize + length bytes)
putWord8s bytes
M.SCEchoReply bytes -> do putH ofptEchoReply (headerSize + length bytes)
putWord8s bytes
M.PacketIn pktInfo -> do let bodyLen = packetInMessageBodyLen pktInfo
putH ofptPacketIn (headerSize + bodyLen)
putPacketInRecord pktInfo
M.Features features -> do putH ofptFeaturesReply (headerSize + 24 + 48 * length (ports features))
putSwitchFeaturesRecord features
M.Error error -> do putH ofptError (headerSize + 2 + 2)
putSwitchError error
where vid = ofpVersion
putH tcode len = putHeader (OFPHeader vid tcode (fromIntegral len) xid)
packetInMessageBodyLen :: PacketInfo -> Int
packetInMessageBodyLen pktInfo = 10 + fromIntegral (packetLength pktInfo)
putPacketInRecord :: PacketInfo -> Put
putPacketInRecord pktInfo@(PacketInfo {..}) =
do putWord32be $ maybe (1) id bufferID
putWord16be $ fromIntegral packetLength
putWord16be receivedOnPort
putWord8 $ reason2Code reasonSent
putWord8 0
putByteString packetData
type OpenFlowVersionID = Word8
ofpVersion :: OpenFlowVersionID
#if OPENFLOW_VERSION == 1
ofpVersion = 0x01
#endif
#if OPENFLOW_VERSION == 152
ofpVersion = 0x98
#endif
#if OPENFLOW_VERSION == 151
ofpVersion = 0x97
#endif
data OFPHeader =
OFPHeader { msgVersion :: !OpenFlowVersionID
, msgType :: !MessageTypeCode
, msgLength :: !Word16
, msgTransactionID :: !M.TransactionID
} deriving (Show,Eq)
headerSize :: Int
headerSize = 8
putHeader :: OFPHeader -> Put
putHeader (OFPHeader {..}) = do putWord8 msgVersion
putWord8 msgType
putWord16be msgLength
putWord32be msgTransactionID
getHeader :: Get OFPHeader
getHeader = do v <- getWord8
t <- getWord8
l <- getWord16be
x <- getWord32be
return $ OFPHeader v t l x
getSCMessageBody :: OFPHeader -> Get (M.TransactionID, M.SCMessage)
getSCMessageBody hdr@(OFPHeader {..}) =
if msgType == ofptPacketIn
then do packetInRecord <- getPacketInRecord len
return (msgTransactionID, M.PacketIn packetInRecord)
else if msgType == ofptEchoRequest
then do bytes <- getWord8s (len headerSize)
return (msgTransactionID, M.SCEchoRequest bytes)
else if msgType == ofptEchoReply
then do bytes <- getWord8s (len headerSize)
return (msgTransactionID, M.SCEchoReply bytes)
else if msgType == ofptFeaturesReply
then do switchFeaturesRecord <- getSwitchFeaturesRecord len
return (msgTransactionID, M.Features switchFeaturesRecord)
else if msgType == ofptHello
then return (msgTransactionID, M.SCHello)
else if msgType == ofptPortStatus
then do body <- getPortStatus
return (msgTransactionID, M.PortStatus body)
else if msgType == ofptError
then do body <- getSwitchError len
return (msgTransactionID, M.Error body)
else if msgType == ofptFlowRemoved
then do body <- getFlowRemovedRecord
return (msgTransactionID, M.FlowRemoved body)
else if msgType == ofptBarrierReply
then return (msgTransactionID, M.BarrierReply)
else if msgType == ofptStatsReply
then do body <- getStatsReply len
return (msgTransactionID, M.StatsReply body)
else if msgType == ofptQueueGetConfigReply
then do qcReply <- getQueueConfigReply len
return (msgTransactionID, M.QueueConfigReply qcReply)
else error ("Unrecognized message header: " ++ show hdr)
where len = fromIntegral msgLength
getCSMessageBody :: OFPHeader -> Get (M.TransactionID, M.CSMessage)
getCSMessageBody header@(OFPHeader {..}) =
if msgType == ofptPacketOut
then do packetOut <- getPacketOut len
return (msgTransactionID, M.PacketOut packetOut)
else if msgType == ofptFlowMod
then do mod <- getFlowMod len
return (msgTransactionID, M.FlowMod mod)
else if msgType == ofptHello
then return (msgTransactionID, M.CSHello)
else if msgType == ofptEchoRequest
then do bytes <- getWord8s (len headerSize)
return (msgTransactionID, M.CSEchoRequest bytes)
else if msgType == ofptEchoReply
then do bytes <- getWord8s (len headerSize)
return (msgTransactionID, M.CSEchoReply bytes)
else if msgType == ofptFeaturesRequest
then return (msgTransactionID, M.FeaturesRequest)
else if msgType == ofptSetConfig
then do _ <- getSetConfig
return (msgTransactionID, M.SetConfig)
else if msgType == ofptVendor
then do () <- getVendorMessage
return (msgTransactionID, M.Vendor)
else error ("Unrecognized message type with header: " ++ show header)
where len = fromIntegral msgLength
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 []
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
getSetConfig :: Get (Word16, Word16)
getSetConfig = do flags <- getWord16be
missSendLen <- getWord16be
return (flags, missSendLen)
getVendorMessage :: Get ()
getVendorMessage
= do r <- remaining
getByteString r
return ()
putSwitchFeaturesRecord (SwitchFeatures {..}) = do
putWord64be switchID
putWord32be $ fromIntegral packetBufferSize
putWord8 $ fromIntegral numberFlowTables
sequence_ $ replicate 3 (putWord8 0)
putWord32be $ switchCapabilitiesBitVector capabilities
putWord32be $ actionTypesBitVector supportedActions
sequence_ [ putPhyPort p | p <- ports ]
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 {..}) =
do putWord16be portID
putEthernetAddress portAddress
mapM_ putWord8 $ 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 = 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 :: Word32
ofppsLinkDown = 1 `shiftL` 0
ofppsStpListen = 0 `shiftL` 8
ofppsStpLearn = 1 `shiftL` 8
ofppsStpForward = 2 `shiftL` 8
ofppsStpBlock = 3 `shiftL` 8
ofppsStpMask = 3 `shiftL` 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 $ enumFrom $ toEnum 0
where inBMap attr = let mask = switchCapability2BitMask attr
in mask .&. bmap == mask
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
#if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152
switchCapability2BitMask MayTransmitOverMultiplePhysicalInterfaces = shiftL 1 4
#endif
switchCapability2BitMask CanReassembleIPFragments = shiftL 1 5
#if OPENFLOW_VERSION==1
switchCapability2BitMask HasQueueStatistics = shiftL 1 6
switchCapability2BitMask CanMatchIPAddressesInARPPackets = shiftL 1 7
#endif
bitMap2SwitchActionSet :: Word32 -> [ActionType]
bitMap2SwitchActionSet bmap = filter inBMap $ enumFrom $ toEnum 0
where inBMap attr = let mask = actionType2BitMask attr
in mask .&. bmap == mask
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
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
actionType2CodeBijection :: Bimap ActionType Word16
actionType2CodeBijection =
Bimap.fromList [(OutputToPortType, 0)
, (SetVlanVIDType, 1)
, (SetVlanPriorityType, 2)
, (StripVlanHeaderType, 3)
, (SetEthSrcAddrType, 4)
, (SetEthDstAddrType, 5)
, (SetIPSrcAddrType, 6)
, (SetIPDstAddrType, 7)
, (SetIPTypeOfServiceType, 8)
, (SetTransportSrcPortType, 9)
, (SetTransportDstPortType, 10)
, (EnqueueType, 11)
, (VendorActionType, 0xffff)
]
actionType2BitMask :: ActionType -> Word32
actionType2BitMask = shiftL 1 . fromIntegral . actionType2Code
getPacketInRecord :: Int -> Get PacketInfo
getPacketInRecord len = do
bufID <- getWord32be
totalLen <- getWord16be
in_port <- getWord16be
reasonCode <- getWord8
skip 1
bytes <- getByteString (fromIntegral data_len)
let reason = code2Reason reasonCode
let mbufID = if (bufID == maxBound) then Nothing else Just bufID
let frame = fst (runGet getEthernetFrame bytes)
return $ PacketInfo mbufID (fromIntegral totalLen) in_port reason bytes frame
where data_offset = 18
data_len = len data_offset
code2Reason :: Word8 -> PacketInReason
code2Reason !code
| code == 0 = NotMatched
| code == 1 = ExplicitSend
| otherwise = error ("Received unknown packet-in reason code: " ++ show code ++ ".")
reason2Code :: PacketInReason -> Word8
reason2Code NotMatched = 0
reason2Code ExplicitSend = 1
getPortStatus :: Get PortStatus
getPortStatus = do
reasonCode <- getWord8
skip 7
portDesc <- getPhyPort
return $ (code2PortStatusUpdateReason reasonCode, portDesc)
code2PortStatusUpdateReason code =
if code == 0
then PortAdded
else if code == 1
then PortDeleted
else if code == 2
then PortModified
else error ("Unkown port status update reason code: " ++ show code)
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 []) =
do putWord16be 1
putWord16be 3
code2ErrorType :: Word16 -> Word16 -> [Word8] -> SwitchError
#if OPENFLOW_VERSION==151
code2ErrorType typ code bytes
| typ == 0 = HelloFailed (helloErrorCodesMap ! code) [ chr (fromIntegral b) | b <- takeWhile (/=0) bytes ]
| typ == 1 = BadRequest (requestErrorCodeMap ! code) bytes
| typ == 2 = BadAction code bytes
| typ == 3 = FlowModFailed code bytes
#endif
#if OPENFLOW_VERSION==152
code2ErrorType typ code bytes
| typ == 0 = HelloFailed (helloErrorCodesMap ! code) [ chr (fromIntegral b) | b <- takeWhile (/=0) bytes ]
| typ == 1 = BadRequest (requestErrorCodeMap ! code) bytes
| typ == 2 = BadAction (actionErrorCodeMap ! code) bytes
| typ == 3 = FlowModFailed (flowModErrorCodeMap ! code) bytes
#endif
#if OPENFLOW_VERSION==1
code2ErrorType typ code bytes
| typ == 0 = HelloFailed (helloErrorCodesMap ! code) [ chr (fromIntegral b) | b <- takeWhile (/=0) bytes ]
| typ == 1 = BadRequest (requestErrorCodeMap ! code) bytes
| typ == 2 = BadAction (actionErrorCodeMap ! code) bytes
| typ == 3 = FlowModFailed (flowModErrorCodeMap ! code) bytes
| typ == 4 = error "Port mod failed error not yet handled"
| typ == 5 = error "Queue op failed error not yet handled"
#endif
helloErrorCodesMap = Bimap.fromList [ (0, IncompatibleVersions)
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
, (1 , HelloPermissionsError)
#endif
]
requestErrorCodeMap = Bimap.fromList [ (0, VersionNotSupported),
(1 , MessageTypeNotSupported),
(2 , StatsRequestTypeNotSupported),
(3 , VendorNotSupported),
(4, VendorSubtypeNotSupported)
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
, (5 , RequestPermissionsError)
#endif
#if OPENFLOW_VERSION==1
, (6 , BadRequestLength)
, (7, BufferEmpty)
, (8, UnknownBuffer)
#endif
]
actionErrorCodeMap = Bimap.fromList [ (0, UnknownActionType),
(1, BadActionLength),
(2, UnknownVendorID),
(3, UnknownActionTypeForVendor),
(4, BadOutPort),
(5, BadActionArgument)
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
, (6, ActionPermissionsError)
#endif
#if OPENFLOW_VERSION==1
, (7, TooManyActions)
, (8, InvalidQueue)
#endif
]
flowModErrorCodeMap = Bimap.fromList [ (0, TablesFull)
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
, (1, OverlappingFlow)
, (2, FlowModPermissionsError)
, (3, EmergencyModHasTimeouts)
#endif
#if OPENFLOW_VERSION==1
, (4, BadCommand)
, (5, UnsupportedActionList)
#endif
]
#if OPENFLOW_VERSION==151
getFlowRemovedRecord :: Get FlowRemoved
getFlowRemovedRecord = do
m <- getMatch
p <- get
rcode <- get
skip 1
dur <- getWord32be
skip 4
pktCount <- getWord64be
byteCount <- getWord64be
return $ FlowRemoved m p (code2FlowRemovalReason rcode) (fromIntegral dur) (fromIntegral pktCount) (fromIntegral byteCount)
#endif
#if OPENFLOW_VERSION==152
getFlowRemovedRecord :: Get FlowRemoved
getFlowRemovedRecord = do
m <- getMatch
p <- getWord16be
rcode <- getWord8
skip 1
dur <- getWord32be
idle_timeout <- getWord16be
skip 6
pktCount <- getWord64be
byteCount <- getWord64be
return $ FlowRemoved m p (code2FlowRemovalReason rcode) (fromIntegral dur) (fromIntegral idle_timeout) (fromIntegral pktCount) (fromIntegral byteCount)
#endif
#if OPENFLOW_VERSION==1
getFlowRemovedRecord :: Get FlowRemoved
getFlowRemovedRecord = do
m <- getMatch
cookie <- getWord64be
p <- getWord16be
rcode <- getWord8
skip 1
dur <- getWord32be
dur_nsec <- getWord32be
idle_timeout <- getWord16be
skip 2
pktCount <- getWord64be
byteCount <- getWord64be
return $ FlowRemovedRecord m cookie p (code2FlowRemovalReason rcode) (fromIntegral dur) (fromIntegral dur_nsec) (fromIntegral idle_timeout) (fromIntegral pktCount) (fromIntegral byteCount)
#endif
#if OPENFLOW_VERSION==151
flowRemovalReason2CodeBijection :: Bimap FlowRemovalReason Word8
flowRemovalReason2CodeBijection =
Bimap.fromList [(IdleTimerExpired, 0),
(HardTimerExpired, 1) ]
#endif
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
flowRemovalReason2CodeBijection :: Bimap FlowRemovalReason Word8
flowRemovalReason2CodeBijection =
Bimap.fromList [(IdleTimerExpired, 0),
(HardTimerExpired, 1),
(DeletedByController, 2) ]
#endif
code2FlowRemovalReason rcode = (Bimap.!>) flowRemovalReason2CodeBijection rcode
getStatsReply :: Int -> Get StatsReply
getStatsReply headerLen = do
statsType <- getWord16be
flags <- getWord16be
let bodyLen = headerLen (headerSize + 4)
let moreFlag = flags == 0x0001
if statsType == ofpstFlow
then do flowStats <- getFlowStatsReplies bodyLen
return (FlowStatsReply moreFlag flowStats)
else if statsType == ofpstPort
then do portStats <- getPortStatsReplies bodyLen
return (PortStatsReply moreFlag portStats)
else if statsType == ofpstAggregate
then do aggStats <- getAggregateStatsReplies bodyLen
return (AggregateFlowStatsReply aggStats)
else if statsType == ofpstTable
then do tableStats <- getTableStatsReplies bodyLen
return (TableStatsReply moreFlag tableStats)
else if statsType == ofpstDesc
then do desc <- getDescriptionReply
return (DescriptionReply desc)
else
#if OPENFLOW_VERSION==1
if statsType == ofpstQueue
then do queueStats <- getQueueStatsReplies bodyLen
return (QueueStatsReply moreFlag queueStats)
else
#endif
error ("unhandled stats reply message with type: " ++ show statsType)
#if OPENFLOW_VERSION==1
getQueueStatsReplies :: Int -> Get [QueueStats]
getQueueStatsReplies bodyLen = do
sequence (replicate cnt getQueueStatsReply)
where cnt = let (d,m) = bodyLen `divMod` queueStatsLength
in if m == 0
then d
else error ("Body of queue stats reply must be a multiple of " ++ show queueStatsLength)
queueStatsLength = 32
getQueueStatsReply = do
portNo <- getWord16be
skip 2
qid <- getWord32be
tx_bytes <- getWord64be
tx_packets <- getWord64be
tx_errs <- getWord64be
return (QueueStats { queueStatsPortID = portNo,
queueStatsQueueID = qid,
queueStatsTransmittedBytes = fromIntegral tx_bytes,
queueStatsTransmittedPackets = fromIntegral tx_packets,
queueStatsTransmittedErrors = fromIntegral tx_errs })
#endif
getDescriptionReply :: Get Description
getDescriptionReply = do
mfr <- getCharsRightPadded descLen
hw <- getCharsRightPadded descLen
sw <- getCharsRightPadded descLen
serial <- getCharsRightPadded descLen
dp <- getCharsRightPadded serialNumLen
return ( Description { manufacturerDesc = mfr
, hardwareDesc = hw
, softwareDesc = sw
, serialNumber = serial
#if OPENFLOW_VERSION==1
, datapathDesc = dp
#endif
} )
where descLen = 256
serialNumLen = 32
getCharsRightPadded :: Int -> Get String
getCharsRightPadded n = do
bytes <- getWord8s n
return [ chr (fromIntegral b) | b <- takeWhile (/=0) bytes]
getTableStatsReplies :: Int -> Get [TableStats]
getTableStatsReplies bodyLen = sequence (replicate cnt getTableStatsReply)
where cnt = let (d,m) = bodyLen `divMod` tableStatsLength
in if m == 0
then d
else error ("Body of Table stats reply must be a multiple of " ++ show tableStatsLength)
tableStatsLength = 64
getTableStatsReply :: Get TableStats
getTableStatsReply = do
tableID <- getWord8
skip 3
name_bytes <- getWord8s maxTableNameLen
let name = [ chr (fromIntegral b) | b <- name_bytes ]
wcards <- getWord32be
maxEntries <- getWord32be
activeCount <- getWord32be
lookupCount <- getWord64be
matchedCount <- getWord64be
return ( TableStats { tableStatsTableID = tableID,
tableStatsTableName = name,
tableStatsMaxEntries = fromIntegral maxEntries,
tableStatsActiveCount = fromIntegral activeCount,
tableStatsLookupCount = fromIntegral lookupCount,
tableStatsMatchedCount = fromIntegral matchedCount } )
where maxTableNameLen = 32
getFlowStatsReplies :: Int -> Get [FlowStats]
getFlowStatsReplies bodyLen
| bodyLen == 0 = return []
| otherwise = do (fs,fsLen) <- getFlowStatsReply
rest <- getFlowStatsReplies (bodyLen fsLen)
return (fs : rest)
getFlowStatsReply :: Get (FlowStats, Int)
getFlowStatsReply = do len <- getWord16be
tid <- getWord8
skip 1
match <- getMatch
dur_sec <- getWord32be
#if OPENFLOW_VERSION==1
dur_nanosec <- getWord32be
#endif
priority <- getWord16be
idle_to <- getWord16be
hard_to <- getWord16be
#if OPENFLOW_VERSION==151
skip 6
#endif
#if OPENFLOW_VERSION==152
skip 2
#endif
#if OPENFLOW_VERSION==1
skip 6
cookie <- getWord64be
#endif
packet_count <- getWord64be
byte_count <- getWord64be
let numActions = (fromIntegral len flowStatsReplySize) `div` actionSize
actions <- sequence (replicate numActions getAction)
let stats = FlowStats { flowStatsTableID = tid,
flowStatsMatch = match,
flowStatsDurationSeconds = fromIntegral dur_sec,
#if OPENFLOW_VERSION==1
flowStatsDurationNanoseconds = fromIntegral dur_nanosec,
#endif
flowStatsPriority = priority,
flowStatsIdleTimeout = fromIntegral idle_to,
flowStatsHardTimeout = fromIntegral hard_to,
#if OPENFLOW_VERSION==1
flowStatsCookie = cookie,
#endif
flowStatsPacketCount = fromIntegral packet_count,
flowStatsByteCount = fromIntegral byte_count,
flowStatsActions = actions }
return (stats, fromIntegral len)
where actionSize = 8
#if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152
flowStatsReplySize = 72
#endif
#if OPENFLOW_VERSION==1
flowStatsReplySize = 88
#endif
getAction :: Get Action
getAction = do
action_type <- getWord16be
action_len <- getWord16be
getActionForType (code2ActionType action_type) action_len
getActionForType :: ActionType -> Word16 -> Get Action
getActionForType OutputToPortType _ =
do port <- getWord16be
max_len <- getWord16be
return (SendOutPort (action port max_len))
where action !port !max_len
| port <= 0xff00 = PhysicalPort port
| port == ofppInPort = InPort
| port == ofppFlood = Flood
| port == ofppAll = AllPhysicalPorts
| port == ofppController = ToController max_len
| port == ofppTable = WithTable
getActionForType SetVlanVIDType _ =
do vlanid <- getWord16be
skip 2
return (SetVlanVID vlanid)
getActionForType SetVlanPriorityType _ =
do pcp <- getWord8
skip 3
return (SetVlanPriority pcp)
getActionForType StripVlanHeaderType _ =
do skip 4
return StripVlanHeader
getActionForType SetEthSrcAddrType _ =
do addr <- getEthernetAddress
skip 6
return (SetEthSrcAddr addr)
getActionForType SetEthDstAddrType _ =
do addr <- getEthernetAddress
skip 6
return (SetEthDstAddr addr)
getActionForType SetIPSrcAddrType _ =
do addr <- getIPAddress
return (SetIPSrcAddr addr)
getActionForType SetIPDstAddrType _ =
do addr <- getIPAddress
return (SetIPDstAddr addr)
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
getActionForType SetIPTypeOfServiceType _ =
do tos <- getWord8
skip 3
return (SetIPToS tos)
#endif
getActionForType SetTransportSrcPortType _ =
do port <- getWord16be
return (SetTransportSrcPort port)
getActionForType SetTransportDstPortType _ =
do port <- getWord16be
return (SetTransportDstPort port)
#if OPENFLOW_VERSION==1
getActionForType EnqueueType _ =
do port <- getWord16be
skip 6
qid <- getWord32be
return (Enqueue port qid)
getActionForType VendorActionType action_len =
do vendorid <- getWord32be
bytes <- getWord8s (fromIntegral action_len 2 2 4)
return (VendorAction vendorid bytes)
#endif
getAggregateStatsReplies :: Int -> Get AggregateFlowStats
getAggregateStatsReplies bodyLen = do
pkt_cnt <- getWord64be
byte_cnt <- getWord64be
flow_cnt <- getWord32be
skip 4
return (AggregateFlowStats (fromIntegral pkt_cnt) (fromIntegral byte_cnt) (fromIntegral flow_cnt))
getPortStatsReplies :: Int -> Get [(PortID,PortStats)]
getPortStatsReplies bodyLen = sequence (replicate numPorts getPortStatsReply)
where numPorts = bodyLen `div` portStatsSize
portStatsSize = 104
getPortStatsReply :: Get (PortID, PortStats)
getPortStatsReply = do port_no <- getWord16be
skip 6
rx_packets <- getWord64be
tx_packets <- getWord64be
rx_bytes <- getWord64be
tx_bytes <- getWord64be
rx_dropped <- getWord64be
tx_dropped <- getWord64be
rx_errors <- getWord64be
tx_errors <- getWord64be
rx_frame_err <- getWord64be
rx_over_err <- getWord64be
rx_crc_err <- getWord64be
collisions <- getWord64be
return $ (port_no,
PortStats {
portStatsReceivedPackets = checkValid rx_packets,
portStatsSentPackets = checkValid tx_packets,
portStatsReceivedBytes = checkValid rx_bytes,
portStatsSentBytes = checkValid tx_bytes,
portStatsReceiverDropped = checkValid rx_dropped,
portStatsSenderDropped = checkValid tx_dropped,
portStatsReceiveErrors = checkValid rx_errors,
portStatsTransmitError = checkValid tx_errors,
portStatsReceivedFrameErrors = checkValid rx_frame_err,
portStatsReceiverOverrunError = checkValid rx_over_err,
portStatsReceiverCRCError = checkValid rx_crc_err,
portStatsCollisions = checkValid collisions }
)
where checkValid :: Word64 -> Maybe Double
checkValid x = if x == 1
then Nothing
else Just (fromIntegral x)
putCSMessage :: (M.TransactionID, M.CSMessage) -> Put
putCSMessage (xid, msg) =
case msg of
M.FlowMod mod -> do let mod'@(FlowModRecordInternal {..}) = flowModToFlowModInternal mod
putH ofptFlowMod (flowModSizeInBytes' actions')
putFlowMod mod'
M.PacketOut packetOut ->
do putH ofptPacketOut (sendPacketSizeInBytes packetOut)
putSendPacket packetOut
M.CSHello -> putH ofptHello headerSize
M.CSEchoRequest bytes -> do putH ofptEchoRequest (headerSize + length bytes)
putWord8s bytes
M.CSEchoReply bytes -> do putH ofptEchoReply (headerSize + length bytes)
putWord8s bytes
M.FeaturesRequest -> putH ofptFeaturesRequest headerSize
M.PortMod portModRecord -> do putH ofptPortMod portModLength
putPortMod portModRecord
M.BarrierRequest -> do putH ofptBarrierRequest headerSize
M.StatsRequest request -> do putH ofptStatsRequest (statsRequestSize request)
putStatsRequest request
M.GetQueueConfig request -> do putH ofptQueueGetConfigRequest 12
putQueueConfigRequest request
where vid = ofpVersion
putH :: Integral a => MessageTypeCode -> a -> Put
putH tcode len = putHeader (OFPHeader vid tcode (fromIntegral len) xid)
putQueueConfigRequest :: QueueConfigRequest -> Put
putQueueConfigRequest (QueueConfigRequest portID) =
do putWord16be portID
putWord16be 0 --padding
sendPacketSizeInBytes :: PacketOut -> Int
sendPacketSizeInBytes (PacketOutRecord bufferIDData _ actions) =
headerSize + 4 + 2 + 2 + sum (map actionSizeInBytes actions) + fromIntegral (either (const 0) B.length bufferIDData)
putSendPacket :: PacketOut -> Put
putSendPacket (PacketOutRecord {..}) = do
putWord32be $ either id (const (1)) bufferIDData
putWord16be (maybe ofppNone id packetInPort)
putWord16be (fromIntegral actionArraySize)
mapM_ putAction packetActions
either (const $ return ()) putByteString bufferIDData
where actionArraySize = sum $ map actionSizeInBytes packetActions
getPacketOut :: Int -> Get PacketOut
getPacketOut len = do
bufID' <- getWord32be
port' <- getWord16be
actionArraySize' <- getWord16be
actions <- getActionsOfSize (fromIntegral actionArraySize')
x <- remaining
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 = actions
}
getActionsOfSize :: Int -> Get [Action]
getActionsOfSize n
| n > 0 = do a <- getAction
as <- getActionsOfSize (n actionSizeInBytes a)
return (a : as)
| n == 0 = return []
| n < 0 = error "bad number of actions or bad action size"
#if OPENFLOW_VERSION==151
flowModSizeInBytes' :: [Action] -> Int
flowModSizeInBytes' actions =
headerSize + matchSize + 20 + sum (map actionSizeInBytes actions)
#endif
#if OPENFLOW_VERSION==152
flowModSizeInBytes' :: [Action] -> Int
flowModSizeInBytes' actions =
headerSize + matchSize + 20 + sum (map actionSizeInBytes actions)
#endif
#if OPENFLOW_VERSION==1
flowModSizeInBytes' :: [Action] -> Int
flowModSizeInBytes' actions =
headerSize + matchSize + 24 + sum (map actionSizeInBytes actions)
#endif
data FlowModRecordInternal = FlowModRecordInternal {
command' :: FlowModType
, match' :: Match
, actions' :: [Action]
, priority' :: Priority
, idleTimeOut' :: Maybe TimeOut
, hardTimeOut' :: Maybe TimeOut
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
, flags' :: [FlowModFlag]
#endif
, bufferID' :: Maybe BufferID
, outPort' :: Maybe PseudoPort
#if OPENFLOW_VERSION==1
, cookie' :: Cookie
#endif
} deriving (Eq,Show)
data FlowModType
= FlowAddType
| FlowModifyType
| FlowModifyStrictType
| FlowDeleteType
| FlowDeleteStrictType
deriving (Show,Eq,Ord)
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
data FlowModFlag = SendFlowRemoved | CheckOverlap | Emergency deriving (Show,Eq,Ord,Enum)
#endif
flowModToFlowModInternal :: FlowMod -> FlowModRecordInternal
flowModToFlowModInternal (DeleteFlows {..}) =
FlowModRecordInternal {match' = match,
#if OPENFLOW_VERSION==1
cookie' = 0,
#endif
command' = FlowDeleteType,
idleTimeOut' = Nothing,
hardTimeOut' = Nothing,
priority' = 0,
bufferID' = Nothing,
outPort' = outPort,
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
flags' = [],
#endif
actions' = []
}
flowModToFlowModInternal (DeleteExactFlow {..}) =
FlowModRecordInternal {match' = match,
#if OPENFLOW_VERSION==1
cookie' = 0,
#endif
command' = FlowDeleteStrictType,
idleTimeOut' = Nothing,
hardTimeOut' = Nothing,
priority' = priority,
bufferID' = Nothing,
outPort' = outPort,
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
flags' = [],
#endif
actions' = []
}
flowModToFlowModInternal (AddFlow {..}) =
FlowModRecordInternal { match' = match,
#if OPENFLOW_VERSION==1
cookie' = cookie,
#endif
command' = FlowAddType,
idleTimeOut' = Just idleTimeOut,
hardTimeOut' = Just hardTimeOut,
priority' = priority,
bufferID' = applyToPacket,
outPort' = Nothing,
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
flags' = concat [ if not overlapAllowed then [CheckOverlap] else [],
if notifyWhenRemoved then [SendFlowRemoved] else []] ,
#endif
actions' = actions
}
flowModToFlowModInternal (AddEmergencyFlow {..}) =
FlowModRecordInternal { match' = match,
#if OPENFLOW_VERSION==1
cookie' = cookie,
#endif
command' = FlowAddType,
idleTimeOut' = Nothing,
hardTimeOut' = Nothing,
priority' = priority,
bufferID' = Nothing,
outPort' = Nothing,
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
flags' = Emergency : if not overlapAllowed then [CheckOverlap] else [],
#endif
actions' = actions
}
flowModToFlowModInternal (ModifyFlows {..}) =
FlowModRecordInternal {match' = match,
#if OPENFLOW_VERSION==1
cookie' = ifMissingCookie,
#endif
command' = FlowModifyType,
idleTimeOut' = Just ifMissingIdleTimeOut,
hardTimeOut' = Just ifMissingHardTimeOut,
priority' = ifMissingPriority,
bufferID' = Nothing,
outPort' = Nothing,
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
flags' = concat [ if not ifMissingOverlapAllowed then [CheckOverlap] else [],
if ifMissingNotifyWhenRemoved then [SendFlowRemoved] else []] ,
#endif
actions' = newActions
}
flowModToFlowModInternal (ModifyExactFlow {..}) =
FlowModRecordInternal {match' = match,
#if OPENFLOW_VERSION==1
cookie' = ifMissingCookie,
#endif
command' = FlowModifyStrictType,
idleTimeOut' = Just ifMissingIdleTimeOut,
hardTimeOut' = Just ifMissingHardTimeOut,
priority' = priority,
bufferID' = Nothing,
outPort' = Nothing,
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
flags' = concat [ if not ifMissingOverlapAllowed then [CheckOverlap] else [],
if ifMissingNotifyWhenRemoved then [SendFlowRemoved] else []] ,
#endif
actions' = newActions
}
#if OPENFLOW_VERSION==151
putFlowMod :: FlowModRecordInternal -> Put
putFlowMod (FlowModRecordInternal {..}) = do
putMatch match'
putWord16be $ flowModTypeBimap ! command'
putWord16be $ maybeTimeOutToCode idleTimeOut'
putWord16be $ maybeTimeOutToCode hardTimeOut'
putWord16be priority'
putWord32be $ maybe (1) id bufferID'
putWord16be $ maybe ofppNone fakePort2Code outPort'
putWord16be 0
putWord32be 0
sequence_ [putAction a | a <- actions']
#endif
#if OPENFLOW_VERSION==152
putFlowMod :: FlowModRecordInternal -> Put
putFlowMod (FlowModRecordInternal {..}) = do
putMatch match'
putWord16be $ flowModTypeBimap ! command'
putWord16be $ maybeTimeOutToCode idleTimeOut'
putWord16be $ maybeTimeOutToCode hardTimeOut'
putWord16be priority'
putWord32be $ maybe (1) id bufferID'
putWord16be $ maybe ofppNone fakePort2Code outPort'
putWord16be $ flagSet2BitMap flags'
putWord32be 0
sequence_ [putAction a | a <- actions']
#endif
#if OPENFLOW_VERSION==1
putFlowMod :: FlowModRecordInternal -> Put
putFlowMod (FlowModRecordInternal {..}) = do
putMatch match'
putWord64be cookie'
putWord16be $ flowModTypeBimap ! command'
putWord16be $ maybeTimeOutToCode idleTimeOut'
putWord16be $ maybeTimeOutToCode hardTimeOut'
putWord16be priority'
putWord32be $ maybe (1) id bufferID'
putWord16be $ maybe ofppNone fakePort2Code outPort'
putWord16be $ flagSet2BitMap flags'
sequence_ [putAction a | a <- actions']
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
flowModInternal2FlowMod :: FlowModRecordInternal -> FlowMod
flowModInternal2FlowMod (FlowModRecordInternal {..}) =
case command' of
FlowDeleteType -> DeleteFlows { match = match', outPort = outPort' }
FlowDeleteStrictType -> DeleteExactFlow { match = match', outPort = outPort', priority = priority' }
FlowAddType ->
if elem Emergency flags'
then AddEmergencyFlow { match = match'
, priority = priority'
, actions = actions'
, cookie = cookie'
, overlapAllowed = elem CheckOverlap flags'
}
else AddFlow { match = match'
, priority = priority'
, actions = actions'
, cookie = cookie'
, idleTimeOut = fromJust idleTimeOut'
, hardTimeOut = fromJust hardTimeOut'
, notifyWhenRemoved = elem SendFlowRemoved flags'
, applyToPacket = bufferID'
, overlapAllowed = elem CheckOverlap flags'
}
FlowModifyType -> ModifyFlows { match = match'
, newActions = actions'
, ifMissingPriority = priority'
, ifMissingCookie = cookie'
, ifMissingIdleTimeOut = fromJust idleTimeOut'
, ifMissingHardTimeOut = fromJust hardTimeOut'
, ifMissingOverlapAllowed = CheckOverlap `elem` flags'
, ifMissingNotifyWhenRemoved = SendFlowRemoved `elem` flags'
}
FlowModifyStrictType -> ModifyExactFlow { match = match'
, newActions = actions'
, priority = priority'
, ifMissingCookie = cookie'
, ifMissingIdleTimeOut = fromJust idleTimeOut'
, ifMissingHardTimeOut = fromJust hardTimeOut'
, ifMissingOverlapAllowed = CheckOverlap `elem` flags'
, ifMissingNotifyWhenRemoved = SendFlowRemoved `elem` flags'
}
#endif
maybeTimeOutToCode :: Maybe TimeOut -> Word16
maybeTimeOutToCode Nothing = 0
maybeTimeOutToCode (Just to) =
case to of
Permanent -> 0
ExpireAfter t -> t
getTimeOutFromCode :: Get (Maybe TimeOut)
getTimeOutFromCode = do code <- getWord16be
if code == 0
then return Nothing
else return (Just (ExpireAfter code))
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
flagSet2BitMap :: [FlowModFlag] -> Word16
flagSet2BitMap flagSet = foldl (.|.) 0 bitMasks
where bitMasks = map (\f -> fromJust $ lookup f flowModFlagToBitMaskBijection) flagSet
flowModFlagToBitMaskBijection :: [(FlowModFlag,Word16)]
flowModFlagToBitMaskBijection = [(SendFlowRemoved, shiftL 1 0),
(CheckOverlap, shiftL 1 1),
(Emergency, shiftL 1 2) ]
bitMap2FlagSet :: Word16 -> [FlowModFlag]
bitMap2FlagSet w = [ flag | (flag,mask) <- flowModFlagToBitMaskBijection, mask .&. w /= 0 ]
getFlowModFlags :: Get [FlowModFlag]
getFlowModFlags = do w <- getWord16be
return (bitMap2FlagSet w)
#endif
ofpfcAdd, ofpfcModify, ofpfcModifyStrict, ofpfcDelete, ofpfcDeleteStrict :: Word16
ofpfcAdd = 0
ofpfcModify = 1
ofpfcModifyStrict = 2
ofpfcDelete = 3
ofpfcDeleteStrict = 4
flowModTypeBimap :: Bimap FlowModType Word16
flowModTypeBimap =
Bimap.fromList [
(FlowAddType, ofpfcAdd),
(FlowModifyType, ofpfcModify),
(FlowModifyStrictType, ofpfcModifyStrict),
(FlowDeleteType, ofpfcDelete),
(FlowDeleteStrictType, ofpfcDeleteStrict)
]
getFlowModType :: Get FlowModType
getFlowModType = do code <- getWord16be
return (flowModTypeBimap !> code)
putAction :: Action -> Put
putAction act =
case act of
(SendOutPort port) ->
do
putWord32be 8
putPseudoPort port
(SetVlanVID vlanid) ->
do putWord16be 1
putWord16be 8
putWord16be vlanid
putWord16be 0
(SetVlanPriority priority) ->
do putWord16be 2
putWord16be 8
putWord8 priority
putWord8 0
putWord8 0
putWord8 0
(StripVlanHeader) ->
do putWord16be 3
putWord16be 8
putWord32be 0
(SetEthSrcAddr addr) ->
do putWord16be 4
putWord16be 16
putEthernetAddress addr
sequence_ (replicate 6 (putWord8 0))
(SetEthDstAddr addr) ->
do putWord16be 5
putWord16be 16
putEthernetAddress addr
sequence_ (replicate 6 (putWord8 0))
(SetIPSrcAddr addr) ->
do putWord16be 6
putWord16be 8
putWord32be (ipAddressToWord32 addr)
(SetIPDstAddr addr) ->
do putWord16be 7
putWord16be 8
putWord32be (ipAddressToWord32 addr)
(SetIPToS tos) ->
do putWord16be 8
putWord16be 8
putWord8 tos
sequence_ (replicate 3 (putWord8 0))
(SetTransportSrcPort port) ->
do putWord16be 9
putWord16be 8
putWord16be port
putWord16be 0
(SetTransportDstPort port) ->
do putWord16be 10
putWord16be 8
putWord16be port
putWord16be 0
(Enqueue port qid) ->
do putWord16be 11
putWord16be 16
putWord16be port
sequence_ (replicate 6 (putWord8 0))
putWord32be qid
(VendorAction vendorID bytes) ->
do let l = 2 + 2 + 4 + length bytes
when (l `mod` 8 /= 0) (error "Vendor action must have enough data to make the action length a multiple of 8 bytes")
putWord16be 0xffff
putWord16be (fromIntegral l)
putWord32be vendorID
mapM_ putWord8 bytes
putPseudoPort :: PseudoPort -> Put
putPseudoPort (ToController maxLen) =
do putWord16be ofppController
putWord16be maxLen
putPseudoPort port =
do putWord16be (fakePort2Code port)
putWord16be 0
actionSizeInBytes :: Action -> Int
actionSizeInBytes (SendOutPort _) = 8
actionSizeInBytes (SetVlanVID _) = 8
actionSizeInBytes (SetVlanPriority _) = 8
actionSizeInBytes StripVlanHeader = 8
actionSizeInBytes (SetEthSrcAddr _) = 16
actionSizeInBytes (SetEthDstAddr _) = 16
actionSizeInBytes (SetIPSrcAddr _) = 8
actionSizeInBytes (SetIPDstAddr _) = 8
actionSizeInBytes (SetIPToS _) = 8
actionSizeInBytes (SetTransportSrcPort _) = 8
actionSizeInBytes (SetTransportDstPort _) = 8
actionSizeInBytes (Enqueue _ _) = 16
actionSizeInBytes (VendorAction _ bytes) = let l = 2 + 2 + 4 + length bytes
in if l `mod` 8 /= 0
then error "Vendor action must have enough data to make the action length a multiple of 8 bytes"
else l
typeOfAction :: Action -> ActionType
typeOfAction !a =
case a of
SendOutPort _ -> OutputToPortType
SetVlanVID _ -> SetVlanVIDType
SetVlanPriority _ -> SetVlanPriorityType
StripVlanHeader -> StripVlanHeaderType
SetEthSrcAddr _ -> SetEthSrcAddrType
SetEthDstAddr _ -> SetEthDstAddrType
SetIPSrcAddr _ -> SetIPSrcAddrType
SetIPDstAddr _ -> SetIPDstAddrType
SetIPToS _ -> SetIPTypeOfServiceType
SetTransportSrcPort _ -> SetTransportSrcPortType
SetTransportDstPort _ -> SetTransportDstPortType
Enqueue _ _ -> EnqueueType
VendorAction _ _ -> VendorActionType
portModLength :: Word16
portModLength = 32
putPortMod :: PortMod -> Put
putPortMod (PortModRecord {..} ) =
do putWord16be portNumber
putEthernetAddress hwAddr
putConfigBitMap
putMaskBitMap
putAdvertiseBitMap
putPad
where putConfigBitMap = putWord32be (portAttributeSet2BitMask onAttrs)
putMaskBitMap = putWord32be (portAttributeSet2BitMask offAttrs)
putAdvertiseBitMap = putWord32be 0
putPad = putWord32be 0
attrsChanging = List.union onAttrs offAttrs
onAttrs = Map.keys $ Map.filter (==True) attributesToSet
offAttrs = Map.keys $ Map.filter (==False) attributesToSet
statsRequestSize :: StatsRequest -> Int
statsRequestSize (FlowStatsRequest _ _ _) = headerSize + 2 + 2 + matchSize + 1 + 1 + 2
#if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152
statsRequestSize (PortStatsRequest) = headerSize + 2 + 2
#endif
#if OPENFLOW_VERSION==1
statsRequestSize (PortStatsRequest _) = headerSize + 2 + 2 + 2 + 6
#endif
putStatsRequest :: StatsRequest -> Put
putStatsRequest (FlowStatsRequest match tableQuery mPort) =
do putWord16be ofpstFlow
putWord16be 0
putMatch match
putWord8 (tableQueryToCode tableQuery)
putWord8 0 --pad
putWord16be $ maybe ofppNone fakePort2Code mPort
putStatsRequest (AggregateFlowStatsRequest match tableQuery mPort) =
do putWord16be ofpstAggregate
putWord16be 0
putMatch match
putWord8 (tableQueryToCode tableQuery)
putWord8 0 --pad
putWord16be $ maybe ofppNone fakePort2Code mPort
putStatsRequest TableStatsRequest =
do putWord16be ofpstTable
putWord16be 0
putStatsRequest DescriptionRequest =
do putWord16be ofpstDesc
putWord16be 0
#if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152
putStatsRequest PortStatsRequest =
do putWord16be ofpstPort
putWord16be 0
#endif
#if OPENFLOW_VERSION==1
putStatsRequest (QueueStatsRequest portQuery queueQuery) =
do putWord16be ofpstQueue
putWord16be 0
putWord16be (queryToPortNumber portQuery)
putWord16be 0 --padding
putWord32be (queryToQueueID queueQuery)
putStatsRequest (PortStatsRequest query) =
do putWord16be ofpstPort
putWord16be 0
putWord16be (queryToPortNumber query)
sequence_ (replicate 6 (putWord8 0))
queryToPortNumber :: PortQuery -> Word16
queryToPortNumber AllPorts = ofppNone
queryToPortNumber (SinglePort p) = p
queryToQueueID :: QueueQuery -> QueueID
queryToQueueID AllQueues = 0xffffffff
queryToQueueID (SingleQueue q) = q
#endif
ofppInPort, ofppTable, ofppNormal, ofppFlood, ofppAll, ofppController, ofppLocal, ofppNone :: Word16
ofppInPort = 0xfff8
ofppTable = 0xfff9
ofppNormal = 0xfffa
ofppFlood = 0xfffb
ofppAll = 0xfffc
ofppController = 0xfffd
ofppLocal = 0xfffe
ofppNone = 0xffff
fakePort2Code :: PseudoPort -> Word16
fakePort2Code (PhysicalPort portID) = portID
fakePort2Code InPort = ofppInPort
fakePort2Code Flood = ofppFlood
fakePort2Code AllPhysicalPorts = ofppAll
fakePort2Code (ToController _) = ofppController
fakePort2Code NormalSwitching = ofppNormal
fakePort2Code WithTable = ofppTable
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
#if OPENFLOW_VERSION==1
tableQueryToCode EmergencyTable = 0xfe
#endif
tableQueryToCode (Table t) = t
#if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152
ofpstDesc, ofpstFlow, ofpstAggregate, ofpstTable, ofpstPort, ofpstVendor :: Word16
ofpstDesc = 0
ofpstFlow = 1
ofpstAggregate = 2
ofpstTable = 3
ofpstPort = 4
ofpstVendor = 0xffff
#endif
#if OPENFLOW_VERSION==1
ofpstDesc, ofpstFlow, ofpstAggregate, ofpstTable, ofpstPort, ofpstQueue, ofpstVendor :: Word16
ofpstDesc = 0
ofpstFlow = 1
ofpstAggregate = 2
ofpstTable = 3
ofpstPort = 4
ofpstQueue = 5
ofpstVendor = 0xffff
#endif
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 m = do
putWord32be $ ofpm_wildcards m'
putWord16be $ ofpm_in_port m'
putEthernetAddress $ ofpm_dl_src m'
putEthernetAddress $ ofpm_dl_dst m'
putWord16be $ ofpm_dl_vlan m'
putWord8 $ ofpm_dl_vlan_pcp m'
putWord8 0
putWord16be $ ofpm_dl_type m'
putWord8 $ ofpm_nw_tos m'
putWord8 $ ofpm_nw_proto m'
putWord16be 0
putWord32be $ ofpm_nw_src m'
putWord32be $ ofpm_nw_dst m'
putWord16be $ ofpm_tp_src m'
putWord16be $ ofpm_tp_dst m'
where m' = match2OFPMatch m
data OFPMatch = OFPMatch { ofpm_wildcards :: !Word32,
ofpm_in_port :: !Word16,
ofpm_dl_src, ofpm_dl_dst :: !EthernetAddress,
ofpm_dl_vlan :: !Word16,
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
ofpm_dl_vlan_pcp :: !Word8,
#endif
ofpm_dl_type :: !Word16,
#if OPENFLOW_VERSION==1
ofpm_nw_tos :: !Word8,
#endif
ofpm_nw_proto :: !Word8,
ofpm_nw_src, ofpm_nw_dst :: !Word32,
ofpm_tp_src, ofpm_tp_dst :: !Word16 } deriving (Show,Eq)
ofpMatch2Match :: OFPMatch -> Match
ofpMatch2Match ofpm = Match
(getField 0 ofpm_in_port)
(getField 2 ofpm_dl_src)
(getField 3 ofpm_dl_dst)
(getField 1 ofpm_dl_vlan)
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
(getField 20 ofpm_dl_vlan_pcp)
#endif
(getField 4 ofpm_dl_type)
#if OPENFLOW_VERSION==1
(getField 21 ofpm_nw_tos)
#endif
(getField 5 ofpm_nw_proto)
(IPAddress (ofpm_nw_src ofpm) // src_prefix_len)
(IPAddress (ofpm_nw_dst ofpm) // dst_prefix_len)
(getField 6 ofpm_tp_src)
(getField 7 ofpm_tp_dst)
where getField :: 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
match2OFPMatch :: Match -> OFPMatch
match2OFPMatch (Match {..})
= OFPMatch { ofpm_wildcards = wildcard',
ofpm_in_port = maybe 0 id inPort,
ofpm_dl_src = maybe nullEthAddr id srcEthAddress,
ofpm_dl_dst = maybe nullEthAddr id dstEthAddress,
ofpm_dl_vlan = maybe 0 id vLANID,
ofpm_dl_vlan_pcp = maybe 0 id vLANPriority,
ofpm_dl_type = maybe 0 id ethFrameType,
ofpm_nw_tos = maybe 0 id ipTypeOfService,
ofpm_nw_proto = maybe 0 id matchIPProtocol,
ofpm_nw_src = fromIntegral $ ipAddressToWord32 $ addressPart srcIPAddress,
ofpm_nw_dst = fromIntegral $ ipAddressToWord32 $ addressPart dstIPAddress,
ofpm_tp_src = maybe 0 id srcTransportPort,
ofpm_tp_dst = maybe 0 id dstTransportPort }
where
wildcard' :: Word32
wildcard' = 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)
nullEthAddr = ethernetAddress 0 0 0 0 0 0
getWord8s :: Int -> Get [Word8]
getWord8s n = sequence $ replicate n getWord8
putWord8s :: [Word8] -> Put
putWord8s bytes = sequence_ [putWord8 b | b <- bytes]