module Nettle.OpenFlow.MessagesBinary (
messageDriver
, openFlowServer
, getSCMessage
, putCSMessage
) where
import Nettle.Ethernet.EthernetAddress
import Nettle.Ethernet.EthernetFrame
import Nettle.IPv4.IPAddress
import Nettle.IPv4.IPPacket
import qualified Nettle.OpenFlow.Messages as M
import Nettle.OpenFlow.Port
import Nettle.OpenFlow.Action
import Nettle.OpenFlow.Switch
import Nettle.OpenFlow.Match
import Nettle.OpenFlow.Packet
import Nettle.OpenFlow.FlowTable
import qualified Nettle.OpenFlow.FlowTable as FlowTable
import Nettle.OpenFlow.Statistics
import Nettle.OpenFlow.Error
import Nettle.Servers.TCPServer
import Nettle.Servers.MultiplexedTCPServer
import Control.Monad (when)
import Control.Exception
import Data.Word
import Data.Bits
import Data.Binary
import Data.Binary.Put
import Data.Binary.Get
import qualified Data.ByteString.Lazy as B
import Data.Maybe (fromJust, isJust)
import Data.List as List
import Data.Char (chr)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Bimap (Bimap, (!))
import qualified Data.Bimap as Bimap
openFlowServer :: ServerPortNumber
-> IO (Process (TCPMessage (M.TransactionID, M.SCMessage)) (SockAddr, (M.TransactionID, M.CSMessage)) IOException)
openFlowServer pnum = muxedTCPServer pnum messageDriver
messageDriver :: TCPMessageDriver (M.TransactionID, M.SCMessage) (M.TransactionID, M.CSMessage)
messageDriver = TCPMessageDriver g p
where g hdl = do
hdrBS <- B.hGet hdl headerSize
let bytesRead = B.length hdrBS
if (bytesRead == 0)
then return Nothing
else do when (bytesRead /= fromIntegral headerSize) (tooFewBytesReadError headerSize bytesRead)
let hdr = runGet getHeader hdrBS
sanityCheck hdr
let expectedLenOfBody = fromIntegral (msgLength hdr) bytesRead
bodyBS <- B.hGet hdl (fromIntegral expectedLenOfBody)
let bytesRead' = B.length bodyBS
when (bytesRead' /= expectedLenOfBody) (tooFewBytesReadError expectedLenOfBody bytesRead')
return (Just (runGet (getSCMessageBody hdr) bodyBS))
tooFewBytesReadError expected actual =
let msg = "Expected to read " ++ show expected ++ " bytes, but only read " ++ show actual ++ "bytes."
in ioError $ userError $ msg
p msg hdl = B.hPut hdl (runPut (putCSMessage msg))
sanityCheck :: OFPHeader -> IO ()
sanityCheck hdr = do
when (msgVersion hdr /= ofpVersion)
(ioError $ userError ("Bytes read from socket do not have the expected version (" ++ show ofpVersion ++ "). Header was: " ++ show hdr))
when (not $ validMessageType $ msgType hdr)
(ioError $ userError ("Bytes read from socket do not have a valid message type. Header was: " ++ show hdr))
type MessageTypeCode = Word8
#if OPENFLOW_VERSION==151
ofptHello :: MessageTypeCode
ofptHello = 0
ofptError :: MessageTypeCode
ofptError = 1
ofptEchoRequest :: MessageTypeCode
ofptEchoRequest = 2
ofptEchoReply :: MessageTypeCode
ofptEchoReply = 3
ofptVendor :: MessageTypeCode
ofptVendor = 4
ofptFeaturesRequest :: MessageTypeCode
ofptFeaturesRequest = 5
ofptFeaturesReply :: MessageTypeCode
ofptFeaturesReply = 6
ofptGetConfigRequest :: MessageTypeCode
ofptGetConfigRequest = 7
ofptGetConfigReply :: MessageTypeCode
ofptGetConfigReply = 8
ofptSetConfig :: MessageTypeCode
ofptSetConfig = 9
ofptPacketIn :: MessageTypeCode
ofptPacketIn = 10
ofptFlowExpired :: MessageTypeCode
ofptFlowExpired = 11
ofptPortStatus :: MessageTypeCode
ofptPortStatus = 12
ofptPacketOut :: MessageTypeCode
ofptPacketOut = 13
ofptFlowMod :: MessageTypeCode
ofptFlowMod = 14
ofptPortMod :: MessageTypeCode
ofptPortMod = 15
ofptStatsRequest :: MessageTypeCode
ofptStatsRequest = 16
ofptStatsReply :: MessageTypeCode
ofptStatsReply = 17
validMessageTypes = [ofptHello,
ofptError,
ofptEchoRequest,
ofptEchoReply,
ofptFeaturesReply,
ofptPacketIn,
ofptFlowExpired,
ofptStatsReply,
ofptPortStatus]
#endif
#if OPENFLOW_VERSION==152
ofptHello :: MessageTypeCode
ofptHello = 0
ofptError :: MessageTypeCode
ofptError = 1
ofptEchoRequest :: MessageTypeCode
ofptEchoRequest = 2
ofptEchoReply :: MessageTypeCode
ofptEchoReply = 3
ofptVendor :: MessageTypeCode
ofptVendor = 4
ofptFeaturesRequest :: MessageTypeCode
ofptFeaturesRequest = 5
ofptFeaturesReply :: MessageTypeCode
ofptFeaturesReply = 6
ofptGetConfigRequest :: MessageTypeCode
ofptGetConfigRequest = 7
ofptGetConfigReply :: MessageTypeCode
ofptGetConfigReply = 8
ofptSetConfig :: MessageTypeCode
ofptSetConfig = 9
ofptPacketIn :: MessageTypeCode
ofptPacketIn = 10
ofptFlowRemoved :: MessageTypeCode
ofptFlowRemoved = 11
ofptPortStatus :: MessageTypeCode
ofptPortStatus = 12
ofptPacketOut :: MessageTypeCode
ofptPacketOut = 13
ofptFlowMod :: MessageTypeCode
ofptFlowMod = 14
ofptPortMod :: MessageTypeCode
ofptPortMod = 15
ofptStatsRequest :: MessageTypeCode
ofptStatsRequest = 16
ofptStatsReply :: MessageTypeCode
ofptStatsReply = 17
ofptBarrierRequest :: MessageTypeCode
ofptBarrierRequest = 18
ofptBarrierReply :: MessageTypeCode
ofptBarrierReply = 19
validMessageTypes = [ofptHello,
ofptError,
ofptEchoRequest,
ofptEchoReply,
ofptFeaturesReply,
ofptPacketIn,
ofptFlowRemoved,
ofptBarrierReply,
ofptStatsReply,
ofptPortStatus]
#endif
#if OPENFLOW_VERSION==1
ofptHello :: MessageTypeCode
ofptHello = 0
ofptError :: MessageTypeCode
ofptError = 1
ofptEchoRequest :: MessageTypeCode
ofptEchoRequest = 2
ofptEchoReply :: MessageTypeCode
ofptEchoReply = 3
ofptVendor :: MessageTypeCode
ofptVendor = 4
ofptFeaturesRequest :: MessageTypeCode
ofptFeaturesRequest = 5
ofptFeaturesReply :: MessageTypeCode
ofptFeaturesReply = 6
ofptGetConfigRequest :: MessageTypeCode
ofptGetConfigRequest = 7
ofptGetConfigReply :: MessageTypeCode
ofptGetConfigReply = 8
ofptSetConfig :: MessageTypeCode
ofptSetConfig = 9
ofptPacketIn :: MessageTypeCode
ofptPacketIn = 10
ofptFlowRemoved :: MessageTypeCode
ofptFlowRemoved = 11
ofptPortStatus :: MessageTypeCode
ofptPortStatus = 12
ofptPacketOut :: MessageTypeCode
ofptPacketOut = 13
ofptFlowMod :: MessageTypeCode
ofptFlowMod = 14
ofptPortMod :: MessageTypeCode
ofptPortMod = 15
ofptStatsRequest :: MessageTypeCode
ofptStatsRequest = 16
ofptStatsReply :: MessageTypeCode
ofptStatsReply = 17
ofptBarrierRequest :: MessageTypeCode
ofptBarrierRequest = 18
ofptBarrierReply :: MessageTypeCode
ofptBarrierReply = 19
ofptQueueGetConfigRequest :: MessageTypeCode
ofptQueueGetConfigRequest = 20
ofptQueueGetConfigReply :: MessageTypeCode
ofptQueueGetConfigReply = 21
validMessageTypes = [ofptHello,
ofptError,
ofptEchoRequest,
ofptEchoReply,
ofptFeaturesReply,
ofptPacketIn,
ofptFlowRemoved,
ofptBarrierReply,
ofptStatsReply,
ofptPortStatus]
#endif
validMessageType tcode = elem tcode validMessageTypes
getSCMessage :: Get (M.TransactionID, M.SCMessage)
getSCMessage = do hdr <- getHeader
getSCMessageBody hdr
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 (OFPHeader {..}) =
if msgType == ofptHello
then return (msgTransactionID, M.SCHello)
else if msgType == ofptEchoRequest
then do bytes <- getWord8s (len headerSize)
return (msgTransactionID, M.SCEchoRequest bytes)
else if msgType == ofptEchoReply
then do bytes <- getWord8s (len headerSize)
return (msgTransactionID, M.SCEchoReply bytes)
else if msgType == ofptFeaturesReply
then do switchFeaturesRecord <- getSwitchFeaturesRecord len
return (msgTransactionID, M.Features switchFeaturesRecord)
else if msgType == ofptPacketIn
then do packetInRecord <- getPacketInRecord len
return (msgTransactionID, M.PacketIn packetInRecord)
else if msgType == ofptPortStatus
then do body <- getPortStatus
return (msgTransactionID, M.PortStatus body)
else if msgType == ofptError
then do body <- getSwitchError len
return (msgTransactionID, M.Error body)
#if OPENFLOW_VERSION==151
else if msgType == ofptFlowExpired
then do body <- getFlowRemovedRecord
return (msgTransactionID, M.FlowRemoved body)
#endif
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
else if msgType == ofptFlowRemoved
then do body <- getFlowRemovedRecord
return (msgTransactionID, M.FlowRemoved body)
else if msgType == ofptBarrierReply
then return (msgTransactionID, M.BarrierReply)
#endif
else if msgType == ofptStatsReply
then do body <- getStatsReply len
return (msgTransactionID, M.StatsReply body)
else error "undefined"
where len = fromIntegral msgLength
getSwitchFeaturesRecord len = do
dpid <- getWord64be
nbufs <- getWord32be
ntables <- getWord8
skip 3
caps <- getWord32be
acts <- getWord32be
ports <- sequence (replicate num_ports getPhyPort)
return (SwitchFeatures dpid (fromIntegral nbufs) (fromIntegral ntables) (bitMap2SwitchCapabilitySet caps) (bitMap2SwitchActionSet acts) ports)
where ports_offset = 32
num_ports = (len ports_offset) `div` size_ofp_phy_port
size_ofp_phy_port = 48
getPhyPort :: Get Port
getPhyPort = do
port_no <- get
hw_addr <- getEthernetAddress
name_arr <- getWord8s ofpMaxPortNameLen
let port_name = [ chr (fromIntegral b) | b <- takeWhile (/=0) name_arr ]
cfg <- getWord32be
st <- getWord32be
let (linkDown, stpState) = code2PortState st
curr <- getWord32be
adv <- getWord32be
supp <- getWord32be
peer <- getWord32be
return $ Port { portID = port_no,
portName = port_name,
portAddress = hw_addr,
portConfig = bitMap2PortConfigAttributeSet cfg,
portLinkDown = linkDown,
portSTPState = stpState,
portCurrentFeatures = decodePortFeatureSet curr,
portAdvertisedFeatures = decodePortFeatureSet adv,
portSupportedFeatures = decodePortFeatureSet supp,
portPeerFeatures = decodePortFeatureSet peer
}
where ofpMaxPortNameLen = 16
decodePortFeatureSet :: Word32 -> Maybe [PortFeature]
decodePortFeatureSet word
| word == 0 = Nothing
| otherwise = Just $ concat [ if word `testBit` position then [feat] else [] | (feat, position) <- featurePositions ]
where featurePositions = [ (Rate10MbHD, 0),
(Rate10MbFD, 1),
(Rate100MbHD, 2),
(Rate100MbFD, 3),
(Rate1GbHD, 4),
(Rate1GbFD, 5),
(Rate10GbFD, 6),
(Copper, 7),
(Fiber, 8),
(AutoNegotiation, 9),
(Pause, 10),
(AsymmetricPause, 11) ]
ofppsLinkDown, ofppsStpListen, ofppsStpLearn, ofppsStpForward :: Word32
ofppsLinkDown = 1 `shiftL` 0
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
bitMap2PortConfigAttributeSet :: Word32 -> [PortConfigAttribute]
bitMap2PortConfigAttributeSet bmap = filter inBMap $ enumFrom $ toEnum 0
where inBMap attr = let mask = portAttribute2BitMask attr
in mask .&. bmap == mask
portAttribute2BitMask :: PortConfigAttribute -> Word32
portAttribute2BitMask PortDown = shiftL 1 0
portAttribute2BitMask STPDisabled = shiftL 1 1
portAttribute2BitMask OnlySTPackets = shiftL 1 2
portAttribute2BitMask NoSTPackets = shiftL 1 3
portAttribute2BitMask NoFlooding = shiftL 1 4
portAttribute2BitMask DropForwarded = shiftL 1 5
portAttribute2BitMask NoPacketInMsg = shiftL 1 6
portAttributeSet2BitMask :: [PortConfigAttribute] -> Word32
portAttributeSet2BitMask = foldl f 0
where f mask b = mask .|. portAttribute2BitMask b
bitMap2SwitchCapabilitySet :: Word32 -> [SwitchCapability]
bitMap2SwitchCapabilitySet bmap = filter inBMap $ enumFrom $ toEnum 0
where inBMap attr = let mask = switchCapability2BitMask attr
in mask .&. bmap == mask
switchCapability2BitMask :: SwitchCapability -> Word32
switchCapability2BitMask HasFlowStats = shiftL 1 0
switchCapability2BitMask HasTableStats = shiftL 1 1
switchCapability2BitMask HasPortStats = shiftL 1 2
switchCapability2BitMask SpanningTree = shiftL 1 3
#if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152
switchCapability2BitMask MayTransmitOverMultiplePhysicalInterfaces = shiftL 1 4
#endif
switchCapability2BitMask CanReassembleIPFragments = shiftL 1 5
#if OPENFLOW_VERSION==1
switchCapability2BitMask HasQueueStatistics = shiftL 1 6
switchCapability2BitMask CanMatchIPAddressesInARPPackets = shiftL 1 7
#endif
bitMap2SwitchActionSet :: Word32 -> [ActionType]
bitMap2SwitchActionSet bmap = filter inBMap $ enumFrom $ toEnum 0
where inBMap attr = let mask = actionType2BitMask attr
in mask .&. bmap == mask
code2ActionType :: Word16 -> ActionType
code2ActionType code =
case Bimap.lookupR code $ actionType2CodeBijection of
Just x -> x
Nothing -> error ("In code2ActionType: encountered unknown action type code: " ++ show code)
actionType2Code :: ActionType -> Word16
actionType2Code a =
case Bimap.lookup a actionType2CodeBijection of
Just x -> x
Nothing -> error ("In actionType2Code: encountered unknown action type: " ++ show a)
#if OPENFLOW_VERSION==151
actionType2CodeBijection :: Bimap ActionType Word16
actionType2CodeBijection =
Bimap.fromList [(OutputToPortType, 0)
, (SetVlanVIDType, 1)
, (SetVlanPriorityType, 2)
, (StripVlanHeaderType, 3)
, (SetEthSrcAddrType, 4)
, (SetEthDstAddrType, 5)
, (SetIPSrcAddrType, 6)
, (SetIPDstAddrType, 7)
, (SetTransportSrcPortType, 8)
, (SetTransportDstPortType, 9)
, (VendorActionType, 0xffff)
]
#endif
#if OPENFLOW_VERSION==152
actionType2CodeBijection :: Bimap ActionType Word16
actionType2CodeBijection =
Bimap.fromList [(OutputToPortType, 0)
, (SetVlanVIDType, 1)
, (SetVlanPriorityType, 2)
, (StripVlanHeaderType, 3)
, (SetEthSrcAddrType, 4)
, (SetEthDstAddrType, 5)
, (SetIPSrcAddrType, 6)
, (SetIPDstAddrType, 7)
, (SetIPTypeOfServiceType, 8)
, (SetTransportSrcPortType, 9)
, (SetTransportDstPortType, 10)
, (VendorActionType, 0xffff)
]
#endif
#if OPENFLOW_VERSION==1
actionType2CodeBijection :: Bimap ActionType Word16
actionType2CodeBijection =
Bimap.fromList [(OutputToPortType, 0)
, (SetVlanVIDType, 1)
, (SetVlanPriorityType, 2)
, (StripVlanHeaderType, 3)
, (SetEthSrcAddrType, 4)
, (SetEthDstAddrType, 5)
, (SetIPSrcAddrType, 6)
, (SetIPDstAddrType, 7)
, (SetIPTypeOfServiceType, 8)
, (SetTransportSrcPortType, 9)
, (SetTransportDstPortType, 10)
, (EnqueueType, 11)
, (VendorActionType, 0xffff)
]
#endif
actionType2BitMask :: ActionType -> Word32
actionType2BitMask = shiftL 1 . fromIntegral . actionType2Code
getPacketInRecord :: Int -> Get PacketInfo
getPacketInRecord len = do
bufID <- getWord32be
totalLen <- getWord16be
in_port <- getWord16be
reasonCode <- getWord8
skip 1
bytes <- getLazyByteString (fromIntegral data_len)
let reason = code2Reason reasonCode
let mbufID = if (bufID == maxBound) then Nothing else Just bufID
return $ PacketInfo mbufID (fromIntegral totalLen) in_port reason bytes
where data_offset = 8 + 4 + 2 + 2 + 1 + 1
data_len = len data_offset
code2Reason code
| code == 0 = NotMatched
| code == 1 = ExplicitSend
| otherwise = error ("Received unknown packet-in reason code: " ++ show code ++ ".")
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)
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 $ FlowRemoved m cookie p (code2FlowRemovalReason rcode) (fromIntegral dur) (fromIntegral dur_nsec) (fromIntegral idle_timeout) (fromIntegral pktCount) (fromIntegral byteCount)
#endif
#if OPENFLOW_VERSION==151
flowRemovalReason2CodeBijection :: Bimap FlowRemovalReason Word8
flowRemovalReason2CodeBijection =
Bimap.fromList [(IdleTimerExpired, 0),
(HardTimerExpired, 1) ]
#endif
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
flowRemovalReason2CodeBijection :: Bimap FlowRemovalReason Word8
flowRemovalReason2CodeBijection =
Bimap.fromList [(IdleTimerExpired, 0),
(HardTimerExpired, 1),
(DeletedByController, 2) ]
#endif
code2FlowRemovalReason rcode = (Bimap.!>) flowRemovalReason2CodeBijection rcode
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.CSHello -> putH ofptHello headerSize
M.CSEchoRequest bytes -> do putH ofptEchoRequest (headerSize + length bytes)
putWord8s bytes
M.CSEchoReply bytes -> do putH ofptEchoReply (headerSize + length bytes)
putWord8s bytes
M.FeaturesRequest -> putH ofptFeaturesRequest headerSize
M.PacketOut packetOut -> do putH ofptPacketOut (sendPacketSizeInBytes packetOut)
putSendPacket packetOut
M.FlowMod mod -> do let mod'@(FlowModRecordInternal {..}) = flowModToFlowModInternal mod
putH ofptFlowMod (flowModSizeInBytes' actions')
putFlowMod mod'
M.PortMod portModRecord -> do putH ofptPortMod portModLength
putPortMod portModRecord
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
M.BarrierRequest -> do putH ofptBarrierRequest headerSize
#endif
M.StatsRequest request -> do putH ofptStatsRequest (statsRequestSize request)
putStatsRequest request
where vid = ofpVersion
putH tcode len = putHeader (OFPHeader vid tcode (fromIntegral len) xid)
sendPacketSizeInBytes :: PacketOut -> Int
sendPacketSizeInBytes (PacketOut bufferIDData _ actions) =
headerSize + 4 + 2 + 2 + sum (map actionSizeInBytes actions) + fromIntegral (either (const 0) B.length bufferIDData)
putSendPacket :: PacketOut -> Put
putSendPacket (PacketOut {..}) = do
putWord32be $ either id (const (1)) bufferIDData
maybe (putWord16be ofppNone) putWord16be inPort
putWord16be (fromIntegral actionArraySize)
sequence_ [putAction a | a <- actions]
either (const $ return ()) putLazyByteString bufferIDData
where actionArraySize = sum $ map actionSizeInBytes actions
#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']
#endif
maybeTimeOutToCode :: Maybe TimeOut -> Word16
maybeTimeOutToCode Nothing = 0
maybeTimeOutToCode (Just to) = case to of
Permanent -> 0
ExpireAfter t -> t
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
flagSet2BitMap :: [FlowModFlag] -> Word16
flagSet2BitMap flagSet = foldl (.|.) 0 bitMasks
where bitMasks = map (\f -> fromJust $ lookup f flowModFlagToBitMaskBijection) flagSet
flowModFlagToBitMaskBijection :: [(FlowModFlag,Word16)]
flowModFlagToBitMaskBijection = [(SendFlowRemoved, shiftL 1 0),
(CheckOverlap, shiftL 1 1),
(Emergency, shiftL 1 2) ]
#endif
ofpfcAdd, ofpfcModify, ofpfcModifyStrict, ofpfcDelete, ofpfcDeleteStrict :: Word16
ofpfcAdd = 0
ofpfcModify = 1
ofpfcModifyStrict = 2
ofpfcDelete = 3
ofpfcDeleteStrict = 4
flowModTypeBimap :: Bimap FlowModType Word16
flowModTypeBimap =
Bimap.fromList [
(FlowAddType, ofpfcAdd),
(FlowModifyType, ofpfcModify),
(FlowModifyStrictType, ofpfcModifyStrict),
(FlowDeleteType, ofpfcDelete),
(FlowDeleteStrictType, ofpfcDeleteStrict)
]
putAction :: Action -> Put
putAction act = do
putWord16be $ actionType2Code $ typeOfAction act
putWord16be (fromIntegral $ actionSizeInBytes act)
case act of
(SendOutPort port) ->
do putPseudoPort port
(SetVlanVID vlanid) ->
do putWord16be vlanid
putWord16be 0
(SetVlanPriority priority) ->
do putWord8 priority
putWord8 0
putWord8 0
putWord8 0
(StripVlanHeader) ->
do putWord32be 0
(SetEthSrcAddr addr) ->
do putEthernetAddress addr
sequence_ (replicate 6 (putWord8 0))
(SetEthDstAddr addr) ->
do putEthernetAddress addr
sequence_ (replicate 6 (putWord8 0))
(SetIPSrcAddr addr) ->
do putWord32be (ipAddressToWord32 addr)
(SetIPDstAddr addr) ->
do putWord32be (ipAddressToWord32 addr)
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
(SetIPToS tos) ->
do putWord8 tos
sequence_ (replicate 3 (putWord8 0))
#endif
(SetTransportSrcPort port) ->
do putWord16be port
putWord16be 0
(SetTransportDstPort port) ->
do putWord16be port
putWord16be 0
#if OPENFLOW_VERSION==1
(Enqueue port qid) ->
do putWord16be port
sequence_ (replicate 6 (putWord8 0))
putWord32be qid
(VendorAction vendorID bytes) ->
do putWord32be vendorID
put bytes
#endif
putPseudoPort :: PseudoPort -> Put
putPseudoPort (ToController maxLen) =
do putWord16be ofppController
putWord16be maxLen
putPseudoPort port =
do putWord16be (fakePort2Code port)
putWord16be 0
actionSizeInBytes :: Action -> Int
actionSizeInBytes (SendOutPort _) = 8
actionSizeInBytes (SetVlanVID _) = 8
actionSizeInBytes (SetVlanPriority _) = 8
actionSizeInBytes StripVlanHeader = 8
actionSizeInBytes (SetEthSrcAddr _) = 16
actionSizeInBytes (SetEthDstAddr _) = 16
actionSizeInBytes (SetIPSrcAddr _) = 8
actionSizeInBytes (SetIPDstAddr _) = 8
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
actionSizeInBytes (SetIPToS _) = 8
#endif
actionSizeInBytes (SetTransportSrcPort _) = 8
actionSizeInBytes (SetTransportDstPort _) = 8
#if OPENFLOW_VERSION==1
actionSizeInBytes (Enqueue _ _) = 16
actionSizeInBytes (VendorAction _ bytes) = let l = 2 + 2 + 4 + length bytes
in if l `mod` 8 /= 0
then error "Vendor action must have enough data to make the action length a multiple of 8 bytes"
else l
#endif
typeOfAction :: Action -> ActionType
typeOfAction a =
case a of
SendOutPort _ -> OutputToPortType
SetVlanVID _ -> SetVlanVIDType
SetVlanPriority _ -> SetVlanPriorityType
StripVlanHeader -> StripVlanHeaderType
SetEthSrcAddr _ -> SetEthSrcAddrType
SetEthDstAddr _ -> SetEthDstAddrType
SetIPSrcAddr _ -> SetIPSrcAddrType
SetIPDstAddr _ -> SetIPDstAddrType
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
SetIPToS _ -> SetIPTypeOfServiceType
#endif
SetTransportSrcPort _ -> SetTransportSrcPortType
SetTransportDstPort _ -> SetTransportDstPortType
#if OPENFLOW_VERSION==1
Enqueue _ _ -> EnqueueType
VendorAction _ _ -> VendorActionType
#endif
portModLength :: Word16
portModLength = 32
putPortMod :: PortMod -> Put
putPortMod (PortMod {..} ) =
do putWord16be portNumber
putEthernetAddress hwAddr
putConfigBitMap
putMaskBitMap
putAdvertiseBitMap
putPad
where putConfigBitMap = putWord32be (portAttributeSet2BitMask onAttrs)
putMaskBitMap = putWord32be (portAttributeSet2BitMask offAttrs)
putAdvertiseBitMap = putWord32be 0
putPad = putWord32be 0
attrsChanging = List.union onAttrs offAttrs
onAttrs = Map.keys $ Map.filter (==True) attributesToSet
offAttrs = Map.keys $ Map.filter (==False) attributesToSet
statsRequestSize :: StatsRequest -> Int
statsRequestSize (FlowStatsRequest _ _ _) = headerSize + 2 + 2 + matchSize + 1 + 1 + 2
#if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152
statsRequestSize (PortStatsRequest) = headerSize + 2 + 2
#endif
#if OPENFLOW_VERSION==1
statsRequestSize (PortStatsRequest _) = headerSize + 2 + 2 + 2 + 6
#endif
putStatsRequest :: StatsRequest -> Put
putStatsRequest (FlowStatsRequest match tableQuery mPort) =
do putWord16be ofpstFlow
putWord16be 0
putMatch match
putWord8 (tableQueryToCode tableQuery)
putWord8 0 --pad
putWord16be $ maybe ofppNone fakePort2Code mPort
putStatsRequest (AggregateFlowStatsRequest match tableQuery mPort) =
do putWord16be ofpstAggregate
putWord16be 0
putMatch match
putWord8 (tableQueryToCode tableQuery)
putWord8 0 --pad
putWord16be $ maybe ofppNone fakePort2Code mPort
putStatsRequest TableStatsRequest =
do putWord16be ofpstTable
putWord16be 0
putStatsRequest DescriptionRequest =
do putWord16be ofpstDesc
putWord16be 0
#if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152
putStatsRequest PortStatsRequest =
do putWord16be ofpstPort
putWord16be 0
#endif
#if OPENFLOW_VERSION==1
putStatsRequest (QueueStatsRequest portQuery queueQuery) =
do putWord16be ofpstQueue
putWord16be 0
putWord16be (queryToPortNumber portQuery)
putWord16be 0 --padding
putWord32be (queryToQueueID queueQuery)
putStatsRequest (PortStatsRequest query) =
do putWord16be ofpstPort
putWord16be 0
putWord16be (queryToPortNumber query)
sequence_ (replicate 6 (putWord8 0))
queryToPortNumber :: PortQuery -> Word16
queryToPortNumber AllPorts = ofppNone
queryToPortNumber (SinglePort p) = p
queryToQueueID :: QueueQuery -> QueueID
queryToQueueID AllQueues = 0xffffffff
queryToQueueID (SingleQueue q) = q
#endif
ofppInPort, ofppTable, ofppNormal, ofppFlood, ofppAll, ofppController, ofppLocal, ofppNone :: Word16
ofppInPort = 0xfff8
ofppTable = 0xfff9
ofppNormal = 0xfffa
ofppFlood = 0xfffb
ofppAll = 0xfffc
ofppController = 0xfffd
ofppLocal = 0xfffe
ofppNone = 0xffff
fakePort2Code :: PseudoPort -> Word16
fakePort2Code (PhysicalPort portID) = portID
fakePort2Code InPort = ofppInPort
fakePort2Code Flood = ofppFlood
fakePort2Code AllPhysicalPorts = ofppAll
fakePort2Code (ToController _) = ofppController
fakePort2Code NormalSwitching = ofppNormal
fakePort2Code WithTable = ofppTable
tableQueryToCode :: TableQuery -> Word8
tableQueryToCode AllTables = 0xff
#if OPENFLOW_VERSION==1
tableQueryToCode EmergencyTable = 0xfe
#endif
tableQueryToCode (Table t) = t
#if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152
ofpstDesc, ofpstFlow, ofpstAggregate, ofpstTable, ofpstPort, ofpstVendor :: Word16
ofpstDesc = 0
ofpstFlow = 1
ofpstAggregate = 2
ofpstTable = 3
ofpstPort = 4
ofpstVendor = 0xffff
#endif
#if OPENFLOW_VERSION==1
ofpstDesc, ofpstFlow, ofpstAggregate, ofpstTable, ofpstPort, ofpstQueue, ofpstVendor :: Word16
ofpstDesc = 0
ofpstFlow = 1
ofpstAggregate = 2
ofpstTable = 3
ofpstPort = 4
ofpstQueue = 5
ofpstVendor = 0xffff
#endif
#if OPENFLOW_VERSION==151
matchSize :: Int
matchSize = 36
#endif
#if OPENFLOW_VERSION==152
matchSize :: Int
matchSize = 40
#endif
#if OPENFLOW_VERSION==1
matchSize :: Int
matchSize = 40
#endif
#if OPENFLOW_VERSION==151
getMatch :: Get Match
getMatch = do
wcards <- getWord32be
inport <- getWord16be
srcEthAddr <- getEthernetAddress
dstEthAddr <- getEthernetAddress
dl_vlan <- getWord16be
dl_type <- getWord16be
nw_proto <- getWord8
getWord8
nw_src <- getWord32be
nw_dst <- getWord32be
tp_src <- getWord16be
tp_dst <- getWord16be
return $ ofpMatch2Match $ OFPMatch wcards inport srcEthAddr dstEthAddr dl_vlan dl_type nw_proto nw_src nw_dst tp_src tp_dst
putMatch :: Match -> Put
putMatch m = do
putWord32be $ ofpm_wildcards m'
putWord16be $ ofpm_in_port m'
putEthernetAddress $ ofpm_dl_src m'
putEthernetAddress $ ofpm_dl_dst m'
putWord16be $ ofpm_dl_vlan m'
putWord16be $ ofpm_dl_type m'
putWord8 $ ofpm_nw_proto m'
putWord8 0
putWord32be $ ofpm_nw_src m'
putWord32be $ ofpm_nw_dst m'
putWord16be $ ofpm_tp_src m'
putWord16be $ ofpm_tp_dst m'
where m' = match2OFPMatch m
#endif
#if OPENFLOW_VERSION==152
getMatch :: Get Match
getMatch = do
wcards <- getWord32be
inport <- getWord16be
srcEthAddr <- getEthernetAddress
dstEthAddr <- getEthernetAddress
dl_vlan <- getWord16be
dl_vlan_pcp <- get
skip 1
dl_type <- getWord16be
nw_proto <- getWord8
skip 3
nw_src <- getWord32be
nw_dst <- getWord32be
tp_src <- getWord16be
tp_dst <- getWord16be
return $ ofpMatch2Match $ OFPMatch wcards inport srcEthAddr dstEthAddr dl_vlan dl_vlan_pcp dl_type nw_proto nw_src nw_dst tp_src tp_dst
putMatch :: Match -> Put
putMatch m = do
putWord32be $ ofpm_wildcards m'
putWord16be $ ofpm_in_port m'
putEthernetAddress $ ofpm_dl_src m'
putEthernetAddress $ ofpm_dl_dst m'
putWord16be $ ofpm_dl_vlan m'
putWord8 $ ofpm_dl_vlan_pcp m'
putWord8 0
putWord16be $ ofpm_dl_type m'
putWord8 $ ofpm_nw_proto m'
putWord8 0
putWord8 0
putWord8 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
#endif
#if OPENFLOW_VERSION==1
getMatch :: Get Match
getMatch = do
wcards <- getWord32be
inport <- getWord16be
srcEthAddr <- getEthernetAddress
dstEthAddr <- getEthernetAddress
dl_vlan <- getWord16be
dl_vlan_pcp <- getWord8
skip 1
dl_type <- getWord16be
nw_tos <- getWord8
nw_proto <- getWord8
skip 2
nw_src <- getWord32be
nw_dst <- getWord32be
tp_src <- getWord16be
tp_dst <- getWord16be
return $ ofpMatch2Match $ OFPMatch wcards inport srcEthAddr dstEthAddr dl_vlan dl_vlan_pcp dl_type nw_tos nw_proto nw_src nw_dst tp_src tp_dst
putMatch :: Match -> Put
putMatch m = do
putWord32be $ ofpm_wildcards m'
putWord16be $ ofpm_in_port m'
putEthernetAddress $ ofpm_dl_src m'
putEthernetAddress $ ofpm_dl_dst m'
putWord16be $ ofpm_dl_vlan m'
putWord8 $ ofpm_dl_vlan_pcp m'
putWord8 0
putWord16be $ ofpm_dl_type m'
putWord8 $ ofpm_nw_tos m'
putWord8 $ ofpm_nw_proto m'
putWord8 0
putWord8 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
#endif
data OFPMatch = OFPMatch { ofpm_wildcards :: Word32,
ofpm_in_port :: Word16,
ofpm_dl_src, ofpm_dl_dst :: EthernetAddress,
ofpm_dl_vlan :: Word16,
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
ofpm_dl_vlan_pcp :: Word8,
#endif
ofpm_dl_type :: Word16,
#if OPENFLOW_VERSION==1
ofpm_nw_tos :: Word8,
#endif
ofpm_nw_proto :: Word8,
ofpm_nw_src, ofpm_nw_dst :: Word32,
ofpm_tp_src, ofpm_tp_dst :: Word16 } deriving (Show,Eq)
ofpMatch2Match :: OFPMatch -> Match
ofpMatch2Match ofpm = Match
(getField 0 ofpm_in_port)
(getField 2 ofpm_dl_src)
(getField 3 ofpm_dl_dst)
(getField 1 ofpm_dl_vlan)
#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1
(getField 20 ofpm_dl_vlan_pcp)
#endif
(getField 4 ofpm_dl_type)
#if OPENFLOW_VERSION==1
(getField 21 ofpm_nw_tos)
#endif
(getField 5 ofpm_nw_proto)
(IPAddress (ofpm_nw_src ofpm) // src_prefix_len)
(IPAddress (ofpm_nw_dst ofpm) // dst_prefix_len)
(getField 6 ofpm_tp_src)
(getField 7 ofpm_tp_dst)
where getField wcindex getter = if testBit (ofpm_wildcards ofpm) wcindex
then Nothing
else Just (getter ofpm)
nw_src_shift = 8
nw_dst_shift = 14
nw_src_mask = shiftL ((shiftL 1 6) 1) nw_src_shift
nw_dst_mask = shiftL ((shiftL 1 6) 1) nw_dst_shift
nw_src_num_ignored = fromIntegral (shiftR (ofpm_wildcards ofpm .&. nw_src_mask) nw_src_shift)
nw_dst_num_ignored = fromIntegral (shiftR (ofpm_wildcards ofpm .&. nw_dst_mask) nw_dst_shift)
src_prefix_len = 32 min 32 nw_src_num_ignored
dst_prefix_len = 32 min 32 nw_dst_num_ignored
#if OPENFLOW_VERSION==151
match2OFPMatch :: Match -> OFPMatch
match2OFPMatch (Match {..}) = foldl (\a f -> f a) m0 fieldSetters
where m0 = OFPMatch 0 0 nullEthAddr nullEthAddr 0 0 0 nwsrcaddr nwdstaddr 0 0
fieldSetters = [setInPort, setDLSrc, setDLDst, setDLVLan,
setDLType, setNWProto, setTPSrc, setTPDst,
updateNWSrcWildcard, updateNWDstWildcard]
setInPort = adjust 0 updateInPort 0 inPort
setDLSrc = adjust 2 updateDLSrc nullEthAddr srcEthAddress
setDLDst = adjust 3 updateDLDst nullEthAddr dstEthAddress
setDLVLan = adjust 1 updateDLVLan 0 vLANID
setDLType = adjust 4 updateDLType 0 ethFrameType
setNWProto = adjust 5 updateNWProto 0 ipProtocol
setTPSrc = adjust 6 updateTPSrc 0 srcTransportPort
setTPDst = adjust 7 updateTPDst 0 dstTransportPort
nwsrcaddr = fromIntegral $ ipAddressToWord32 $ addressPart srcIPAddress
nwdstaddr = fromIntegral $ ipAddressToWord32 $ addressPart dstIPAddress
modifyWildcardBits f m' = m' { ofpm_wildcards = f (ofpm_wildcards m') }
updateNWSrcWildcard =
let numIgnoredBits = 32 (prefixLength srcIPAddress)
f wc = wc .|. shiftL (fromIntegral numIgnoredBits) 8
in modifyWildcardBits f
updateNWDstWildcard =
let numIgnoredBits = 32 (prefixLength dstIPAddress)
f wc = wc .|. shiftL (fromIntegral numIgnoredBits) 14
in modifyWildcardBits f
nullEthAddr = EthernetAddress 0 0 0 0 0 0
setWildcardBit i m' = m' { ofpm_wildcards = setBit (ofpm_wildcards m') i }
clearWildcardBit i m' = m' { ofpm_wildcards = clearBit (ofpm_wildcards m') i }
updateInPort v m' = m' { ofpm_in_port = v }
updateDLSrc v m' = m' { ofpm_dl_src = v }
updateDLDst v m' = m' { ofpm_dl_dst = v }
updateDLVLan v m' = m' { ofpm_dl_vlan = v }
updateDLType v m' = m' { ofpm_dl_type = v }
updateNWProto v m'= m' { ofpm_nw_proto = v }
updateNWSrc v m' = m' { ofpm_nw_src = v }
updateNWDst v m' = m' { ofpm_nw_dst = v }
updateTPSrc v m' = m' { ofpm_tp_src = v }
updateTPDst v m' = m' { ofpm_tp_dst = v }
adjust wildcardIndex updater nullValue mv m' =
case mv of
Nothing -> setWildcardBit wildcardIndex $ updater nullValue m'
Just v -> clearWildcardBit wildcardIndex $ updater v m'
#endif
#if OPENFLOW_VERSION==152
match2OFPMatch :: Match -> OFPMatch
match2OFPMatch (Match {..}) = foldl (\a f -> f a) m0 fieldSetters
where m0 = OFPMatch 0 0 nullEthAddr nullEthAddr 0 0 0 0 nwsrcaddr nwdstaddr 0 0
fieldSetters = [setInPort, setDLSrc, setDLDst, setDLVLan, setDLVLanPriority,
setDLType, setNWProto, setTPSrc, setTPDst,
updateNWSrcWildcard, updateNWDstWildcard]
setInPort = adjust 0 updateInPort 0 inPort
setDLSrc = adjust 2 updateDLSrc nullEthAddr srcEthAddress
setDLDst = adjust 3 updateDLDst nullEthAddr dstEthAddress
setDLVLan = adjust 1 updateDLVLan 0 vLANID
setDLVLanPriority = adjust 20 updateDLVLanPcp 0 vLANPriority
setDLType = adjust 4 updateDLType 0 ethFrameType
setNWProto = adjust 5 updateNWProto 0 ipProtocol
setTPSrc = adjust 6 updateTPSrc 0 srcTransportPort
setTPDst = adjust 7 updateTPDst 0 dstTransportPort
nwsrcaddr = fromIntegral $ ipAddressToWord32 $ addressPart srcIPAddress
nwdstaddr = fromIntegral $ ipAddressToWord32 $ addressPart dstIPAddress
modifyWildcardBits f m' = m' { ofpm_wildcards = f (ofpm_wildcards m') }
updateNWSrcWildcard =
let numIgnoredBits = 32 (prefixLength srcIPAddress)
f wc = wc .|. shiftL (fromIntegral numIgnoredBits) 8
in modifyWildcardBits f
updateNWDstWildcard =
let numIgnoredBits = 32 (prefixLength dstIPAddress)
f wc = wc .|. shiftL (fromIntegral numIgnoredBits) 14
in modifyWildcardBits f
nullEthAddr = EthernetAddress 0 0 0 0 0 0
setWildcardBit i m' = m' { ofpm_wildcards = setBit (ofpm_wildcards m') i }
clearWildcardBit i m' = m' { ofpm_wildcards = clearBit (ofpm_wildcards m') i }
updateInPort v m' = m' { ofpm_in_port = v }
updateDLSrc v m' = m' { ofpm_dl_src = v }
updateDLDst v m' = m' { ofpm_dl_dst = v }
updateDLVLan v m' = m' { ofpm_dl_vlan = v }
updateDLVLanPcp v m' = m' { ofpm_dl_vlan_pcp = v }
updateDLType v m' = m' { ofpm_dl_type = v }
updateNWProto v m'= m' { ofpm_nw_proto = v }
updateNWSrc v m' = m' { ofpm_nw_src = v }
updateNWDst v m' = m' { ofpm_nw_dst = v }
updateTPSrc v m' = m' { ofpm_tp_src = v }
updateTPDst v m' = m' { ofpm_tp_dst = v }
adjust wildcardIndex updater nullValue mv m' =
case mv of
Nothing -> setWildcardBit wildcardIndex $ updater nullValue m'
Just v -> clearWildcardBit wildcardIndex $ updater v m'
#endif
#if OPENFLOW_VERSION==1
match2OFPMatch :: Match -> OFPMatch
match2OFPMatch (Match {..}) = foldl (\a f -> f a) m0 fieldSetters
where m0 = OFPMatch { ofpm_wildcards = 0,
ofpm_in_port = 0,
ofpm_dl_src = nullEthAddr,
ofpm_dl_dst = nullEthAddr,
ofpm_dl_vlan = 0,
ofpm_dl_vlan_pcp = 0,
ofpm_dl_type = 0,
ofpm_nw_tos = 0,
ofpm_nw_proto = 0,
ofpm_nw_src = nwsrcaddr,
ofpm_nw_dst = nwdstaddr,
ofpm_tp_src = 0,
ofpm_tp_dst = 0 }
fieldSetters = [setInPort, setDLSrc, setDLDst, setDLVLan, setDLVLanPriority,
setDLType, setNWToS, setNWProto, setTPSrc, setTPDst,
updateNWSrcWildcard, updateNWDstWildcard]
setInPort = adjust 0 updateInPort 0 inPort
setDLSrc = adjust 2 updateDLSrc nullEthAddr srcEthAddress
setDLDst = adjust 3 updateDLDst nullEthAddr dstEthAddress
setDLVLan = adjust 1 updateDLVLan 0 vLANID
setDLVLanPriority = adjust 20 updateDLVLanPcp 0 vLANPriority
setDLType = adjust 4 updateDLType 0 ethFrameType
setNWToS = adjust 21 updateNWToS 0 ipTypeOfService
setNWProto = adjust 5 updateNWProto 0 ipProtocol
setTPSrc = adjust 6 updateTPSrc 0 srcTransportPort
setTPDst = adjust 7 updateTPDst 0 dstTransportPort
nwsrcaddr = fromIntegral $ ipAddressToWord32 $ addressPart srcIPAddress
nwdstaddr = fromIntegral $ ipAddressToWord32 $ addressPart dstIPAddress
modifyWildcardBits f m' = m' { ofpm_wildcards = f (ofpm_wildcards m') }
updateNWSrcWildcard =
let numIgnoredBits = 32 (prefixLength srcIPAddress )
f wc = wc .|. shiftL (fromIntegral numIgnoredBits) 8
in modifyWildcardBits f
updateNWDstWildcard =
let numIgnoredBits = 32 (prefixLength dstIPAddress )
f wc = wc .|. shiftL (fromIntegral numIgnoredBits) 14
in modifyWildcardBits f
nullEthAddr = EthernetAddress 0 0 0 0 0 0
setWildcardBit i m' = m' { ofpm_wildcards = setBit (ofpm_wildcards m') i }
clearWildcardBit i m' = m' { ofpm_wildcards = clearBit (ofpm_wildcards m') i }
updateInPort v m' = m' { ofpm_in_port = v }
updateDLSrc v m' = m' { ofpm_dl_src = v }
updateDLDst v m' = m' { ofpm_dl_dst = v }
updateDLVLan v m' = m' { ofpm_dl_vlan = v }
updateDLVLanPcp v m' = m' { ofpm_dl_vlan_pcp = v }
updateDLType v m' = m' { ofpm_dl_type = v }
updateNWToS v m' = m' { ofpm_nw_tos = v }
updateNWProto v m'= m' { ofpm_nw_proto = v }
updateNWSrc v m' = m' { ofpm_nw_src = v }
updateNWDst v m' = m' { ofpm_nw_dst = v }
updateTPSrc v m' = m' { ofpm_tp_src = v }
updateTPDst v m' = m' { ofpm_tp_dst = v }
adjust wildcardIndex updater nullValue mv m' =
case mv of
Nothing -> setWildcardBit wildcardIndex $ updater nullValue m'
Just v -> clearWildcardBit wildcardIndex $ updater v m'
#endif
getWord8s :: Int -> Get [Word8]
getWord8s n = sequence $ replicate n getWord8
putWord8s :: [Word8] -> Put
putWord8s bytes = sequence_ [putWord8 b | b <- bytes]