{-# LANGUAGE RecordWildCards #-}
{- | [Haskell OpenFlow]
This is an implementation of OpenFlow in Haskell.
-}
module Network.OpenFlow (
OfpFrame(..)
, OfpHeader(..)
, OfpMsg(..)
, OfpError(..)
, OfpHelloFailedCode(..)
, OfpBadRequestCode(..)
, OfpBadActionCode(..)
, OfpFlowModFailedCode(..)
, OfpPortModFailedCode(..)
, OfpQueueOpFailedCode(..)
, OfpSwitchFeatures(..)
, OfpPhyPort(..)
, OfpCapabilities(..)
, OfpActionType(..)
, OfpPortConfig(..)
, OfpPortState(..)
, OfpPortFeatures(..)
, OfpSwitchConfig(..)
, OfpConfigFlags(..)
, OfpFlowMod(..)
, OfpMatch(..)
, OfpFlowModCommand(..)
, OfpFlowModFlags(..)
, OfpAction(..)
, OfpFlowWildcards(..)
, OfpPacketIn(..)
, OfpPacketInReason(..)
, OfpPacketOut(..)
, OfpFlowRemoved(..)
, OfpFlowRemovedReason(..)
, OfpPortStatus(..)
, OfpPortReason(..)
, OfpPortMod(..)
, OfpQueueGetConfigRequest(..)
, OfpQueueGetConfigReply(..)
, OfpPacketQueue(..)
, OfpQueueProp(..)
, readOfpFrame
) where
import GHC.Word
import Control.Monad
import Data.Functor
import Data.Bits
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C
import Data.Serialize
import Data.Serialize.Get
import Data.Serialize.Put
import Network.Socket hiding (recv)
import Network.Socket.ByteString
import Network.Info
data OfpFrame =
-- 5.1 Each OpenFlow message begins with the OpenFlow header
OfpFrame { hdr :: OfpHeader
, msg :: OfpMsg
} deriving (Show)
instance Serialize OfpFrame where
put (OfpFrame (OfpHeader version _ _ xid) msg) = do
putWord8 version
putWord8 $ msgType msg
let bs = runPut $ putOfpMsg msg
let len = ofpHdrLen + (BS.length bs)
put ((fromIntegral len) :: Word16)
putWord32be xid
putByteString bs
get = do
hdr <- get :: Get OfpHeader
msg <- getOfpMsg hdr
return $ OfpFrame hdr msg
data OfpHeader =
OfpHeader { version :: Word8
, ty :: Word8
, len :: Word16
, xid :: Word32
} deriving (Show)
ofpHdrLen = 8
instance Serialize OfpHeader where
put (OfpHeader {..}) = do
putWord8 version
putWord8 ty
putWord16be len
putWord32be xid
get = do
version <- liftM fromIntegral getWord8
ty <- liftM fromIntegral getWord8
len <- liftM fromIntegral getWord16be
xid <- liftM fromIntegral getWord32be
return $ OfpHeader version ty len xid
data OfpMsg = OfptHello [Word8]
| OfptError OfpError
| OfptEchoRequest [Word8]
| OfptEchoReply [Word8]
| OfptVendor
| OfptFeaturesRequest
| OfptFeaturesReply OfpSwitchFeatures
| OfptGetConfigRequest
| OfptGetConfigReply OfpSwitchConfig
| OfptSetConfig OfpSwitchConfig
| OfptPacketIn OfpPacketIn
| OfptFlowRemoved OfpFlowRemoved
| OfptPortStatus OfpPortStatus
| OfptPacketOut OfpPacketOut
| OfptFlowMod OfpFlowMod
| OfptPortMod OfpPortMod
| OfptBarrierRequest
| OfptBarrierReply
| OfptQueueGetConfigRequest OfpQueueGetConfigRequest
| OfptQueueGetConfigReply OfpQueueGetConfigReply
deriving (Show)
-- | Immutable messages
msgType (OfptHello _) = 0
msgType (OfptError _) = 1
msgType (OfptEchoRequest _) = 2
msgType (OfptEchoReply _) = 3
msgType (OfptVendor) = 4
-- | Switch configuration messages
msgType (OfptFeaturesRequest) = 5
msgType (OfptFeaturesReply _) = 6
msgType (OfptGetConfigRequest) = 7
msgType (OfptGetConfigReply _) = 8
msgType (OfptSetConfig _) = 9
-- | Asynchronous messages
msgType (OfptPacketIn _) = 10
msgType (OfptFlowRemoved _) = 11
msgType (OfptPortStatus _) = 12
-- | Controller command messages
msgType (OfptPacketOut _) = 13
msgType (OfptFlowMod _) = 14
msgType (OfptPortMod _) = 15
-- | Statistics messages
--msgType (OfptStatsRequest) = 16
--msgType (OfptStatsReply) = 17
-- | Barrier messages
msgType (OfptBarrierRequest) = 18
msgType (OfptBarrierReply) = 19
-- | Queue configuration messages
msgType (OfptQueueGetConfigRequest _) = 20
msgType (OfptQueueGetConfigReply _) = 21
data OfpError = OfpetHelloFailed OfpHelloFailedCode String
| OfpetBadRequest OfpBadRequestCode
| OfpetBadAction OfpBadActionCode
| OfpetFlowModFailed OfpFlowModFailedCode
| OfpetPortModFailed OfpPortModFailedCode
| OfpetQueueOpFailed OfpQueueOpFailedCode
deriving (Show)
data OfpHelloFailedCode = OfphfcIncompatible
| OfphfcEperm
deriving (Show, Enum)
data OfpBadRequestCode = OfpbrcBadVersion
| OfpbrcBadType
| OfpbrcBadStat
| OfpbrcBadVendor
| OfpbrcBadSubtype
| OfpbrcEperm
| OfpbrcBadLen
| OfpbrcBufferEmpty
| OfpbrcBufferUnknown
deriving (Show, Enum)
data OfpBadActionCode = OfpbacBadType
| OfpbacBadLen
| OfpbacBadVendor
| OfpbacBadVendorType
| OfpbacBadOutPort
| OfpbacBadArgument
| OfpbacEperm
| OfpbacTooMany
| OfpbacBadQueue
deriving (Show, Enum)
data OfpFlowModFailedCode = OfpfmfcAllTablesFull
| OfpfmfcOverlap
| OfpfmfcEperm
| OfpfmfcBadEmergTimeout
| OfpfmfcBadCommand
| OfpfmfcUnsupported
deriving (Show, Enum)
data OfpPortModFailedCode = OfppmfcBadPort
| OfppmfcBadHwAddr
deriving (Show, Enum)
data OfpQueueOpFailedCode = OfpqofcBadPort
| OfpqofcBadQueue
| OfpqofcEperm
deriving (Show, Enum)
data OfpSwitchFeatures =
OfpSwitchFeatures { dataPathId :: Word64
, nBuffers :: Word32
, nTables :: Word8
, capabilities :: [OfpCapabilities]
, actions :: [OfpActionType]
, ports :: [OfpPhyPort]
} deriving (Show)
data OfpCapabilities = OfpcFlowStats
| OfpcTableStats
| OfpcPortStats
| OfpcStp
| OfpcReserved
| OfpcIpReasm
| OfpcQueueStats
| OfpcArpMatchIp
deriving (Show, Enum)
data OfpActionType = OfpatOutput
| OfpatSetVlanVid
| OfpatSetVlanPcp
| OfpatStripVlan
| OfpatSetDlSrc
| OfpatSetDlDst
| OfpatSetNwSrc
| OfpatSetNwDst
| OfpatSetNwTos
| OfpatSetTpSrc
| OfpatSetTpDst
| OfpatEnqueue
| OfpatVendor
deriving (Show, Enum)
data OfpPhyPort =
OfpPhyPort { portNo :: Word16
, hwAddr :: MAC
, name :: String
, config :: [OfpPortConfig]
, state :: [OfpPortState]
, curr :: [OfpPortFeatures]
, advertised :: [OfpPortFeatures]
, supported :: [OfpPortFeatures]
, peer :: [OfpPortFeatures]
} deriving (Show)
instance Serialize MAC where
put (MAC w1 w2 w3 w4 w5 w6) = do
putWord8 w1
putWord8 w2
putWord8 w3
putWord8 w4
putWord8 w5
putWord8 w6
get = do
w1 <- liftM fromIntegral getWord8
w2 <- liftM fromIntegral getWord8
w3 <- liftM fromIntegral getWord8
w4 <- liftM fromIntegral getWord8
w5 <- liftM fromIntegral getWord8
w6 <- liftM fromIntegral getWord8
return $ MAC w1 w2 w3 w4 w5 w6
ofpMaxPortNameLen = 16
prependSpace xs 0 = xs
prependSpace xs n = prependSpace (" " ++ xs) (n-1)
instance Serialize OfpPhyPort where
put (OfpPhyPort {..}) = do
putWord16be portNo
put hwAddr
putByteString $ C.pack $ prependSpace name (ofpMaxPortNameLen - (length name))
putWord32be $ enumToBitInst config
putWord32be $ enumToBitInst state
putWord32be $ enumToBitInst curr
putWord32be $ enumToBitInst advertised
putWord32be $ enumToBitInst supported
putWord32be $ enumToBitInst peer
get = do
portNo <- liftM fromIntegral getWord16be
hwAddr <- get :: Get MAC
nameBS <- getByteString ofpMaxPortNameLen
let name = C.unpack nameBS
configBits <- getWord32be
stateBits <- getWord32be
currBits <- getWord32be
advertisedBits <- getWord32be
supportedBits <- getWord32be
peerBits <- getWord32be
let config = word32ToEnum configBits
let state = word32ToEnum stateBits
let curr = word32ToEnum currBits
let advertised = word32ToEnum advertisedBits
let supported = word32ToEnum supportedBits
let peer = word32ToEnum peerBits
return $ OfpPhyPort portNo hwAddr name config state curr advertised supported peer
data OfpPortConfig = OfppcPortDown
| OfppcNoStp
| OfppcNoRecv
| OfppcNoRecvStp
| OfppcNoFlood
| OfppcNoFwd
| OfppcNoPacketIn
deriving (Show, Enum)
data OfpPortState = OfppsLinkDown
| OfppsStpListen
| OfppsStpLearn
| OfppsStpForward
| OfppsStpBlock
| OfppsStpMask
deriving (Show, Enum)
data OfpPortFeatures = Ofppf10MbHd
| Ofppf10MbFd
| Ofppf100MbHd
| Ofppf100MbFd
| Ofppf1GbHd
| Ofppf1GbFd
| Ofppf10GbFd
| OfppfCopper
| OfppfFiber
| OfppfAutoneg
| OfppfPause
| OfppfPauseAsym
deriving (Show, Enum)
data OfpSwitchConfig =
OfpSwitchConfig { flags :: [OfpConfigFlags]
, missSendLen :: Word16
} deriving (Show)
instance Serialize OfpSwitchConfig where
put (OfpSwitchConfig {..}) = do
putWord16be $ enumToBitInst flags
putWord16be missSendLen
get = do
flagsBits <- getWord16be
let flags = word16ToEnum flagsBits
missSendLen <- getWord16be
return $ OfpSwitchConfig flags missSendLen
data OfpConfigFlags = OfpcFragNormal
| OfpcFragDrop
| OfpcFragReasm
| OfpcFragMask
deriving (Show, Enum)
data OfpFlowMod =
OfpFlowMod { match :: OfpMatch
, cookie :: Word64
, command :: OfpFlowModCommand
, idleTimeout :: Word16
, hardTimeout :: Word16
, priority :: Word16
, bufferId :: Word32
, outPort :: Word16
, fmFlags :: OfpFlowModFlags
, fmActions :: [OfpAction]
} deriving (Show)
instance Serialize OfpFlowMod where
put (OfpFlowMod {..}) = do
put match
putWord64be cookie
putWord16be $ fromIntegral $ fromEnum command
putWord16be idleTimeout
putWord16be hardTimeout
putWord16be priority
putWord32be bufferId
putWord16be outPort
putWord16be $ fromIntegral $ fromEnum fmFlags
mapM_ put fmActions
get = do
match <- get :: Get OfpMatch
cookie <- getWord64be
command' <- liftM fromIntegral getWord16be
let command = toEnum command' :: OfpFlowModCommand
idleTimeout <- getWord16be
hardTimeout <- getWord16be
priority <- getWord16be
bufferId <- getWord32be
outPort <- getWord16be
flags' <- liftM fromIntegral getWord16be
let flags = toEnum flags' :: OfpFlowModFlags
rem <- remaining
actionsBS <- getByteString rem
let actions = readMany actionsBS
return $ OfpFlowMod match cookie command idleTimeout hardTimeout priority bufferId outPort flags actions
data OfpAction = OfpOutput Word16 Word16
| OfpSetVlanVid Word16
| OfpSetVlanPcp Word8
| OfpStripVlan
| OfpSetDlSrc MAC
| OfpSetDlDst MAC
| OfpSetNwSrc Word32
| OfpSetNwDst Word32
| OfpSetNwTos Word8
| OfpSetTpSrc Word16
| OfpSetTpDst Word16
| OfpEnqueue Word16 Word32
| OfpVendor
deriving (Show)
instance Serialize OfpAction where
put (OfpOutput port maxLen) = do
putWord16be 0
putWord16be 8
putWord16be port
putWord16be maxLen
put (OfpSetVlanVid vlanVid) = do
putWord16be 1
putWord16be 8
putWord16be vlanVid
putWord16be 0 -- pad
put (OfpSetVlanPcp vlanPcp) = do
putWord16be 2
putWord16be 8
putWord8 vlanPcp
putWord8 0 -- pad
putWord8 0 -- pad
putWord8 0 -- pad
put (OfpStripVlan) = do
putWord16be 3
putWord16be 8
putWord32be 0 -- pad
put (OfpSetDlSrc mac) = do
putWord16be 4
putWord16be 16
put mac
putWord16be 0 -- pad
putWord16be 0 -- pad
putWord16be 0 -- pad
put (OfpSetDlDst mac) = do
putWord16be 5
putWord16be 16
put mac
putWord16be 0 -- pad
putWord16be 0 -- pad
putWord16be 0 -- pad
put (OfpSetNwSrc nwAddr) = do
putWord16be 6
putWord16be 8
putWord32be nwAddr
put (OfpSetNwDst nwAddr) = do
putWord16be 7
putWord16be 8
putWord32be nwAddr
put (OfpSetNwTos nwTos) = do
putWord16be 8
putWord16be 8
putWord8 nwTos
putWord8 0 -- pad
putWord8 0 -- pad
putWord8 0 -- pad
put (OfpSetTpSrc tpPort) = do
putWord16be 9
putWord16be 8
putWord16be tpPort
putWord16be 0 -- pad
put (OfpSetTpDst tpPort) = do
putWord16be 10
putWord16be 8
putWord16be tpPort
putWord16be 0 -- pad
put (OfpEnqueue port queueId) = do
putWord16be 11
putWord16be 16
putWord16be port
putWord16be 0 -- pad
putWord32be 0 -- pad
putWord32be queueId
put (OfpVendor) = do
putWord16be 0xffff
putWord16be 8
putWord32be 0 -- pad
get = do
ty <- getWord16be
len <- getWord16be
case ty of
0 -> do
port <- getWord16be
maxLen <- getWord16be
return $ OfpOutput port maxLen
1 -> do
vlanVid <- getWord16be
pad1 <- getWord16be
return $ OfpSetVlanVid vlanVid
2 -> do
vlanPcp <- getWord8
pad1 <- getWord8
pad2 <- getWord8
pad3 <- getWord8
return $ OfpSetVlanPcp vlanPcp
3 -> do
pad1 <- getWord32be
return $ OfpStripVlan
4 -> do
mac <- get :: Get MAC
pad1 <- getWord16be
pad2 <- getWord16be
pad3 <- getWord16be
return $ OfpSetDlSrc mac
5 -> do
mac <- get :: Get MAC
pad1 <- getWord16be
pad2 <- getWord16be
pad3 <- getWord16be
return $ OfpSetDlDst mac
6 -> do
nwAddr <- getWord32be
return $ OfpSetNwSrc nwAddr
7 -> do
nwAddr <- getWord32be
return $ OfpSetNwDst nwAddr
8 -> do
nwTos <- getWord8
pad1 <- getWord8
pad2 <- getWord8
pad2 <- getWord8
return $ OfpSetNwTos nwTos
9 -> do
tpPort <- getWord16be
pad1 <- getWord16be
return $ OfpSetTpSrc tpPort
10 -> do
tpPort <- getWord16be
pad1 <- getWord16be
return $ OfpSetTpDst tpPort
11 -> do
port <- getWord16be
pad1 <- getWord16be
pad2 <- getWord32be
queueId <- getWord32be
return $ OfpEnqueue port queueId
0xffff -> return OfpVendor
data OfpMatch =
OfpMatch { wildcards :: [OfpFlowWildcards]
, inPort :: Word16
, dlSrc :: MAC
, dlDst :: MAC
, dlVlan :: Word16
, dlVlanPcp :: Word8
, dlType :: Word16
, nwTos :: Word8
, nwProto :: Word8
, nwSrc :: Word32
, nwDst :: Word32
, tpSrc :: Word16
, tpDst :: Word16
} deriving (Show)
instance Serialize OfpMatch where
put (OfpMatch {..}) = do
putWord32be $ enumToBitInst wildcards
putWord16be inPort
put dlSrc
put dlDst
putWord16be dlVlan
putWord8 dlVlanPcp
putWord8 0
putWord16be dlType
putWord8 nwTos
putWord8 nwProto
putWord8 0
putWord8 0
putWord32be nwSrc
putWord32be nwDst
putWord16be tpSrc
putWord16be tpDst
get = do
wildcardBits <- getWord32be
let wildcards = word32ToEnum wildcardBits
inPort <- getWord16be
dlSrc <- get :: Get MAC
dlDst <- get :: Get MAC
dlVlan <- getWord16be
dlVlanPcp <- getWord8
pad1 <- getWord8
dlType <- getWord16be
nwTos <- getWord8
nwProto <- getWord8
pad2 <- getWord8
pad3 <- getWord8
nwSrc <- getWord32be
nwDst <- getWord32be
tpSrc <- getWord16be
tpDst <- getWord16be
return $ OfpMatch wildcards inPort dlSrc dlDst dlVlan dlVlanPcp dlType nwTos nwProto nwSrc nwDst tpSrc tpDst
data OfpFlowWildcards = OfpfwInPort
| OfpfwDlVlan
| OfpfwDlSrc
| OfpfwDlDst
| OfpfwDlType
| OfpfwNwProto
| OfpfwTpSrc
| OfpfwTpDst
| OfpfwNwSrc -- incomplete! 6 bits
| OfpfwNwDst -- incomplete! 6 bits
| OfpfwDlVlanPcp
| OfpfwNwTos
| OfpfwAll
deriving (Show)
instance Enum OfpFlowWildcards where
fromEnum (OfpfwInPort) = 0
fromEnum (OfpfwDlVlan) = 1
fromEnum (OfpfwDlSrc) = 2
fromEnum (OfpfwDlDst) = 3
fromEnum (OfpfwDlType) = 4
fromEnum (OfpfwNwProto) = 5
fromEnum (OfpfwTpSrc) = 6
fromEnum (OfpfwTpDst) = 7
fromEnum (OfpfwNwSrc) = 8
fromEnum (OfpfwNwDst) = 14
fromEnum (OfpfwDlVlanPcp) = 20
fromEnum (OfpfwNwTos) = 21
fromEnum (OfpfwAll) = 22
toEnum 0 = (OfpfwInPort)
toEnum 1 = (OfpfwDlVlan)
toEnum 2 = (OfpfwDlSrc)
toEnum 3 = (OfpfwDlDst)
toEnum 4 = (OfpfwDlType)
toEnum 5 = (OfpfwNwProto)
toEnum 6 = (OfpfwTpSrc)
toEnum 7 = (OfpfwTpDst)
toEnum 8 = (OfpfwNwSrc)
toEnum 14 = (OfpfwNwDst)
toEnum 20 = (OfpfwDlVlanPcp)
toEnum 21 = (OfpfwNwTos)
toEnum 22 = (OfpfwAll)
allWildcards = [ OfpfwInPort, OfpfwDlVlan, OfpfwDlSrc,
OfpfwDlDst, OfpfwDlType, OfpfwNwProto,
OfpfwTpSrc, OfpfwTpDst, OfpfwNwSrc, OfpfwNwDst,
OfpfwDlVlanPcp, OfpfwNwTos, OfpfwAll ]
data OfpFlowModCommand = OfpfcAdd
| OfpfcModify
| OfpfcModifyStrict
| OfpfcDelete
| OfpfcDeleteStrict
deriving (Show, Enum)
data OfpFlowModFlags = OfpffSendFlowRem
| OfpffCheckOverlap
| OfpffEmerg
deriving (Show, Enum)
data OfpPacketIn =
OfpPacketIn { piBufferId :: Word32
, totalLen :: Word16
, piInPort :: Word16
, reason :: OfpPacketInReason
, dat :: [Word8]
} deriving (Show)
instance Serialize OfpPacketIn where
put (OfpPacketIn {..}) = do
let dat' = BS.pack dat
let len = BS.length dat'
putWord32be piBufferId
put ((fromIntegral len) :: Word16)
putWord16be piInPort
putWord8 $ fromIntegral $ fromEnum reason
putByteString dat'
get = do
bufferId <- getWord32be
totalLen <- getWord16be
inPort <- getWord16be
reason' <- liftM fromIntegral getWord8
let reason = toEnum reason' :: OfpPacketInReason
rem <- remaining
-- assert(rem == totalLen)
dat' <- getByteString rem
let dat = BS.unpack dat'
return $ OfpPacketIn bufferId totalLen inPort reason dat
data OfpPacketInReason = OfprNoMatch
| OfprAction
deriving (Show, Enum)
data OfpPacketOut =
OfpPacketOut { poBufferId :: Word32
, poInPort :: Word16
, poActions :: [OfpAction]
, poDat :: [Word8]
} deriving (Show)
instance Serialize OfpPacketOut where
put (OfpPacketOut {..}) = do
putWord32be poBufferId
putWord16be poInPort
let actions' = runPut (mapM_ put poActions)
let len = BS.length actions'
put ((fromIntegral len) :: Word16)
putByteString actions'
putByteString $ BS.pack poDat
get = do
bufferId <- getWord32be
inPort <- getWord16be
actionsLen <- getWord16be
actionsBS <- getByteString (fromIntegral actionsLen)
let actions = readMany actionsBS
rem <- remaining
dat' <- getByteString rem
let dat = BS.unpack dat'
return $ OfpPacketOut bufferId inPort actions dat
data OfpFlowRemoved =
OfpFlowRemoved { frMatch :: OfpMatch
, frCookie :: Word64
, frPriority :: Word16
, frReason :: OfpFlowRemovedReason
, durationSec :: Word32
, durationNSec :: Word32
, frIdleTimeout :: Word16
, packetCount :: Word64
, byteCount :: Word64
} deriving (Show)
instance Serialize OfpFlowRemoved where
put (OfpFlowRemoved match cookie pri reason sec nsec idleTO pCnt bCnt) = do
put match
putWord64be cookie
putWord16be pri
putWord8 $ fromIntegral $ fromEnum reason
putWord32be sec
putWord32be nsec
putWord16be idleTO
putWord64be pCnt
putWord64be bCnt
get = do
match <- get :: Get OfpMatch
cookie <- getWord64be
pri <- getWord16be
reason' <- liftM fromIntegral getWord8
let reason = toEnum reason' :: OfpFlowRemovedReason
sec <- getWord32be
nsec <- getWord32be
idleTO <- getWord16be
pCnt <- getWord64be
bCnt <- getWord64be
return $ OfpFlowRemoved match cookie pri reason sec nsec idleTO pCnt bCnt
data OfpFlowRemovedReason = OfprrIdleTimeout
| OfprrHardTimeout
| OfprrDelete
deriving (Show, Enum)
data OfpPortStatus =
OfpPortStatus { psReason :: OfpPortReason
, desc :: OfpPhyPort
} deriving (Show)
instance Serialize OfpPortStatus where
put (OfpPortStatus reason desc) = do
putWord8 $ fromIntegral $ fromEnum reason
putWord32be 0 -- pad
putWord16be 0 -- pad
putWord8 0 -- pad
put desc
get = do
reason' <- liftM fromIntegral getWord8
let reason = toEnum reason' :: OfpPortReason
pad1 <- getWord32be
pad2 <- getWord16be
pad3 <- getWord8
desc <- get :: Get OfpPhyPort
return $ OfpPortStatus reason desc
data OfpPortReason = OfpprAdd
| OfpprDelete
| OfpprModify
deriving (Show, Enum)
data OfpPortMod =
OfpPortMod { pmPortNo :: Word16
, pmHwAddr :: MAC
, pmConfig :: [OfpPortConfig]
, pmMask :: [OfpPortConfig]
, pmAdvertise :: [OfpPortFeatures]
} deriving (Show)
instance Serialize OfpPortMod where
put (OfpPortMod portNo hwAddr config mask adv) = do
putWord16be portNo
put hwAddr
putWord32be $ enumToBitInst config
putWord32be $ enumToBitInst mask
putWord32be $ enumToBitInst adv
putWord32be 0 -- pad
get = do
portNo <- getWord16be
hwAddr <- get :: Get MAC
config' <- getWord32be
mask' <- getWord32be
adv' <- getWord32be
pad <- getWord32be
let config = word32ToEnum config'
let mask = word32ToEnum mask'
let adv = word32ToEnum adv'
return $ OfpPortMod portNo hwAddr config mask adv
data OfpQueueGetConfigRequest =
OfpQueueGetConfigRequest { qreqPort :: Word16
} deriving (Show)
instance Serialize OfpQueueGetConfigRequest where
put (OfpQueueGetConfigRequest port) = do
putWord16be port
putWord16be 0 -- pad
get = do
port <- getWord16be
pad <- getWord16be
return $ OfpQueueGetConfigRequest port
data OfpQueueGetConfigReply =
OfpQueueGetConfigReply { qrepPort :: Word16
, queues :: [OfpPacketQueue]
} deriving (Show)
instance Serialize OfpQueueGetConfigReply where
put (OfpQueueGetConfigReply port queues) = do
putWord16be port
putWord32be 0 -- pad
putWord16be 0 -- pad
mapM_ put queues
get = do
port <- getWord16be
pad1 <- getWord32be
pad2 <- getWord16be
rem <- remaining
queuesBS <- getByteString rem
let queues = readMany queuesBS
return $ OfpQueueGetConfigReply port queues
data OfpPacketQueue =
OfpPacketQueue { pqQueueId :: Word32
, properties :: [OfpQueueProp]
} deriving (Show)
instance Serialize OfpPacketQueue where
put (OfpPacketQueue qid props) = do
putWord32be qid
let props' = runPut (mapM_ put props)
let len = BS.length props'
put ((fromIntegral len) :: Word16)
putWord16be 0 -- pad
putByteString props'
get = do
qid <- getWord32be
len <- getWord16be
pad <- getWord16be
propsBS <- getByteString (fromIntegral len)
let props = readMany propsBS
return $ OfpPacketQueue qid props
data OfpQueueProp = OfpqtNone
| OfpqtMinRate Word16
deriving (Show)
instance Serialize OfpQueueProp where
put (OfpqtNone) = do
putWord16be 0
putWord16be 8
putWord32be 0 -- pad
put (OfpqtMinRate rate) = do
putWord16be 1
putWord16be 16
putWord32be 0 -- pad
putWord16be rate
putWord32be 0 -- pad
putWord16be 0 -- pad
get = do
property <- getWord16be
len <- getWord16be
pad1 <- getWord32be
case property of
0 -> return OfpqtNone
1 -> do
rate <- getWord16be
pad2 <- getWord32be
pad3 <- getWord16be
return $ OfpqtMinRate rate
putOfpErrorMsg ty code = do
putWord16be ty
putWord16be $ fromIntegral $ fromEnum code
enumToBitInst :: (Enum a, Bits b) => [a] -> b
enumToBitInst xs = f xs 0
where
f xs' w = foldl (\ w x -> w `setBit` fromEnum x) w xs
putOfpMsg :: OfpMsg -> Put
putOfpMsg (OfptHello msg) = putByteString $ BS.pack msg
putOfpMsg (OfptError (OfpetHelloFailed code msg)) = do
putOfpErrorMsg 0 code
putByteString $ C.pack msg
putOfpMsg (OfptError (OfpetBadRequest code)) = putOfpErrorMsg 1 code
putOfpMsg (OfptError (OfpetBadAction code)) = putOfpErrorMsg 2 code
putOfpMsg (OfptError (OfpetFlowModFailed code)) = putOfpErrorMsg 3 code
putOfpMsg (OfptError (OfpetPortModFailed code)) = putOfpErrorMsg 4 code
putOfpMsg (OfptError (OfpetQueueOpFailed code)) = putOfpErrorMsg 5 code
putOfpMsg (OfptEchoRequest dat) = putByteString $ BS.pack dat
putOfpMsg (OfptEchoReply dat) = putByteString $ BS.pack dat
putOfpMsg (OfptVendor) = putByteString BS.empty
putOfpMsg (OfptFeaturesRequest) = putByteString BS.empty
putOfpMsg (OfptFeaturesReply (OfpSwitchFeatures dip nbuf ntab caps actions ports)) = do
putWord64be dip
putWord32be nbuf
putWord8 ntab
putWord8 0 -- pad
putWord8 0 -- pad
putWord8 0 -- pad
putWord32be $ enumToBitInst caps
putWord32be $ enumToBitInst actions
mapM_ put ports
putOfpMsg (OfptGetConfigRequest) = putByteString BS.empty
putOfpMsg (OfptGetConfigReply switchConfig) = put switchConfig
putOfpMsg (OfptSetConfig switchConfig) = put switchConfig
putOfpMsg (OfptPacketIn packetIn) = put packetIn
putOfpMsg (OfptFlowRemoved flowRemoved) = put flowRemoved
putOfpMsg (OfptPortStatus portStatus) = put portStatus
putOfpMsg (OfptPacketOut packetOut) = put packetOut
putOfpMsg (OfptFlowMod flowMod) = put flowMod
putOfpMsg (OfptPortMod portMod) = put portMod
putOfpMsg (OfptBarrierRequest) = putByteString BS.empty
putOfpMsg (OfptBarrierReply) = putByteString BS.empty
putOfpMsg (OfptQueueGetConfigRequest qreq) = put qreq
putOfpMsg (OfptQueueGetConfigReply qrep) = put qrep
readMany :: (Serialize t) => BS.ByteString -> [t]
readMany bs = case runGet (readMany' [] 0) bs of
Left err -> error err
Right t -> t
where
readMany _ 1000 = error "readMany overflow"
readMany' l n = do
x <- get
rem <- remaining
if rem > 0
then readMany' (x:l) (n+1)
else return (x:l)
bitInstToEnum :: (Enum a, Bits b) => b -> Int -> [a]
bitInstToEnum w width = f 0 []
where
f i xs = if i == width
then xs
else f (i+1) xs ++ [toEnum i | w `testBit` i]
word16ToEnum word = bitInstToEnum word 16
word32ToEnum word = bitInstToEnum word 32
word64ToEnum word = bitInstToEnum word 64
getOfpMsg (OfpHeader _ ty len _) =
case ty of
0 -> OfptHello <$> getMsg
1 -> getOfptError len'
2 -> OfptEchoRequest <$> getMsg
3 -> OfptEchoReply <$> getMsg
4 -> return OfptVendor
5 -> return OfptFeaturesRequest
6 -> getOfptFeaturesReply len'
7 -> return OfptGetConfigRequest
8 -> OfptGetConfigReply <$> get
9 -> OfptSetConfig <$> get
10 -> OfptPacketIn <$> get
11 -> OfptFlowRemoved <$> get
12 -> OfptPortStatus <$> get
13 -> OfptPacketOut <$> get
14 -> OfptFlowMod <$> get
15 -> OfptPortMod <$> get
18 -> return OfptBarrierRequest
19 -> return OfptBarrierReply
20 -> OfptQueueGetConfigRequest <$> get
21 -> OfptQueueGetConfigReply <$> get
where
len' = fromIntegral len
getMsg = liftM BS.unpack (getByteString (len' - ofpHdrLen))
getOfptError len = do
ty <- liftM fromIntegral getWord16be
code <- liftM fromIntegral getWord16be
OfptError <$> case ty of
0 -> do
bs <- getByteString (len - ofpHdrLen - 4)
return $ OfpetHelloFailed (toEnum code :: OfpHelloFailedCode) (C.unpack bs)
1 -> return $ OfpetBadRequest (toEnum code :: OfpBadRequestCode)
2 -> return $ OfpetBadAction (toEnum code :: OfpBadActionCode)
3 -> return $ OfpetFlowModFailed (toEnum code :: OfpFlowModFailedCode)
4 -> return $ OfpetPortModFailed (toEnum code :: OfpPortModFailedCode)
5 -> return $ OfpetQueueOpFailed (toEnum code :: OfpQueueOpFailedCode)
_ -> error $ "bad error type"
getOfptFeaturesReply len = do
dip <- liftM fromIntegral getWord64be
nbuf <- liftM fromIntegral getWord32be
ntab <- liftM fromIntegral getWord8
pad1 <- getWord8
pad2 <- getWord8
pad3 <- getWord8
capBits <- getWord32be
actBits <- getWord32be
phyPortsBS <- getByteString (len - ofpHdrLen - 24)
let caps = word32ToEnum capBits
let actions = word32ToEnum actBits
let ports = readMany phyPortsBS
return (OfptFeaturesReply (OfpSwitchFeatures dip nbuf ntab caps actions ports))
-- | Socket functions
peekHdrLen dat =
case runGet getHdrLen dat of
Left err -> error err
Right len -> fromIntegral len
where
getHdrLen = do
OfpHeader _ _ len _ <- get :: Get OfpHeader
return len
readOfpFrame :: Socket -> IO OfpFrame
readOfpFrame sock = do
dat <- recvExact ofpHdrLen
let bytesLeft = (peekHdrLen dat) - ofpHdrLen
if bytesLeft /= 0
then do dat' <- recvExact bytesLeft
case runGet get (BS.append dat dat') of
Left err -> error err
Right frame -> return frame
else do case runGet get dat of
Left err -> error err
Right frame -> return frame
where
recvExact bytes = do
b <- recvExact' bytes BS.empty
if BS.length b /= fromIntegral bytes
then error "expected.."
else return b
recvExact' bytes buf = do
dat <- recv sock bytes
let len = BS.length dat
if len == 0
then error "peer closed connection"
else do let buf' = BS.append buf dat
if len >= bytes
then return buf'
else recvExact' (bytes-len) buf'