diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2012, Brian Brooks +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Brian Brooks nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/OpenFlow.hs b/Network/OpenFlow.hs new file mode 100644 --- /dev/null +++ b/Network/OpenFlow.hs @@ -0,0 +1,1066 @@ +{-# 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' diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/echo-client.hs b/examples/echo-client.hs new file mode 100644 --- /dev/null +++ b/examples/echo-client.hs @@ -0,0 +1,62 @@ +import Data.Serialize +import Network.Socket hiding (recv) +import Network.Socket.ByteString +import Network.OpenFlow +import Network.Info + +mac1 = MAC 1 2 3 4 5 6 +mac2 = MAC 7 8 9 0 1 2 + +phyPort1 = OfpPhyPort 0 mac1 "port1" [OfppcPortDown] [OfppsLinkDown] [OfppfFiber] [OfppfFiber] [OfppfFiber] [OfppfFiber] +phyPort2 = OfpPhyPort 1 mac2 "port2" [OfppcNoStp, OfppcNoFlood] [OfppsLinkDown] [OfppfFiber, OfppfAutoneg] [OfppfFiber, OfppfPause] [OfppfFiber] [OfppfFiber] + + +emptyMac = MAC 0x00 0x00 0x00 0x00 0x00 0x00 + +inp = 1 +outp = 6 + +wc = [--OfpfwInPort, + OfpfwDlVlan, OfpfwDlSrc + , OfpfwDlDst, OfpfwDlType, OfpfwNwProto + , OfpfwTpSrc, OfpfwTpDst, OfpfwNwSrcShift + , OfpfwNwSrcBits, OfpfwNwSrcMask, OfpfwNwSrcAll + , OfpfwDlVlanPcp, OfpfwNwTos, OfpfwAll + ] +m = OfpMatch wc inp emptyMac emptyMac 0 0 0 0 0 0 0 0 0 + +act1 = OfpOutput outp 256 +flowMod = OfpFlowMod m 0 OfpfcAdd 360 360 1 100 outp OfpffSendFlowRem [act1] + + +main :: IO () +main = do + addrinfos <- getAddrInfo + (Just (defaultHints {addrFlags = [AI_PASSIVE]})) + Nothing (Just "9999") + let serveaddr = head addrinfos + sock <- socket (addrFamily serveaddr) Stream defaultProtocol + connect sock (addrAddress serveaddr) + + bounce sock (OfpFrame (OfpHeader 1 0 0 42) (OfptHello [])) + bounce sock (OfpFrame (OfpHeader 1 0 0 42) (OfptError (OfpetHelloFailed OfphfcIncompatible "incompatible! foo bar_ 43"))) + bounce sock (OfpFrame (OfpHeader 1 0 0 42) (OfptFeaturesReply (OfpSwitchFeatures 0 0 0 [OfpcFlowStats, OfpcQueueStats] [OfpatOutput, OfpatEnqueue] [phyPort1, phyPort2]))) + bounce sock (OfpFrame (OfpHeader 1 0 0 42) (OfptGetConfigReply (OfpSwitchConfig [OfpcFragNormal, OfpcFragMask] 1234))) + bounce sock (OfpFrame (OfpHeader 1 0 0 42) (OfptFlowMod flowMod)) + bounce sock $ mkFrame (OfptPacketIn (OfpPacketIn 1 1 1 OfprNoMatch [])) + bounce sock $ mkFrame (OfptBarrierRequest) + bounce sock $ mkFrame (OfptPacketOut (OfpPacketOut 1 1 [(OfpOutput 1 1)] [])) + bounce sock $ mkFrame (OfptPacketOut (OfpPacketOut 1 1 [(OfpOutput 1 1), (OfpStripVlan)] [1,2])) + bounce sock $ mkFrame (OfptFlowRemoved (OfpFlowRemoved m 0 4 OfprrIdleTimeout 1 2 3 4 5)) + bounce sock $ mkFrame (OfptPortStatus (OfpPortStatus OfpprModify phyPort1)) + bounce sock $ mkFrame (OfptPortMod (OfpPortMod 1 mac1 [OfppcPortDown] [OfppcNoFwd, OfppcNoStp] [Ofppf10MbHd])) + bounce sock $ mkFrame (OfptQueueGetConfigReply (OfpQueueGetConfigReply 1 [(OfpPacketQueue 0 [OfpqtNone]), (OfpPacketQueue 1 [OfpqtNone, (OfpqtMinRate 550)])])) + + sClose sock + + where + mkFrame msg = (OfpFrame (OfpHeader 1 0 0 42) msg) + bounce sock' frame = do + sendAll sock' $ encode frame + frame <- readOfpFrame sock' + putStrLn $ "recv: " ++ show frame diff --git a/examples/echo-server.hs b/examples/echo-server.hs new file mode 100644 --- /dev/null +++ b/examples/echo-server.hs @@ -0,0 +1,25 @@ +import Control.Monad +import qualified Data.ByteString as BS +import Network.Socket hiding (recv) +import Network.Socket.ByteString + +main :: IO () +main = do + addrinfos <- getAddrInfo + (Just (defaultHints {addrFlags = [AI_PASSIVE]})) + Nothing (Just "9999") + let serveaddr = head addrinfos + sock <- socket (addrFamily serveaddr) Stream defaultProtocol + bindSocket sock (addrAddress serveaddr) + listen sock 4 + (conn, caddr) <- accept sock + talk conn + sClose conn + sClose sock + main + where + talk :: Socket -> IO () + talk conn = do + msg <- recv conn 4096 + unless (BS.null msg) $ sendAll conn msg >> talk conn + diff --git a/examples/server.hs b/examples/server.hs new file mode 100644 --- /dev/null +++ b/examples/server.hs @@ -0,0 +1,112 @@ +import Control.Monad +import Control.Concurrent +import Data.Serialize +import Network.Socket hiding (recv) +import Network.Socket.ByteString +import Network.OpenFlow +import Network.Info +import System.Environment +import Data.Bits +import GHC.Word + +main :: IO () +main = do + addrinfos <- getAddrInfo + (Just (defaultHints {addrFlags = [AI_PASSIVE]})) + Nothing (Just "6633") + let serveaddr = head addrinfos + sock <- socket (addrFamily serveaddr) Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bindSocket sock (addrAddress serveaddr) + listen sock 4 + serveConns sock + +serveConns :: Socket -> IO () +serveConns sock = + forever $ do + (csock, caddr) <- accept sock + handshake csock + flood csock + _ <- forkIO $ handleSwitch csock caddr + return () + +handshake :: Socket -> IO () +handshake sock = do + sendAll sock $ encode (OfpFrame (OfpHeader 1 0 0 0) (OfptHello [])) + frame <- readOfpFrame sock + putStrLn $ "RX: " ++ show frame + sendAll sock $ encode (OfpFrame (OfpHeader 1 0 0 1) (OfptGetConfigRequest)) + frame <- readOfpFrame sock + putStrLn $ "RX: " ++ show frame + sendAll sock $ encode (OfpFrame (OfpHeader 1 0 0 2) (OfptFeaturesRequest)) + frame <- readOfpFrame sock + putStrLn $ "RX: " ++ show frame + +handleSwitch :: Socket -> SockAddr -> IO () +handleSwitch sock caddr = + forever $ do + frame <- readOfpFrame sock + putStrLn $ "RX: " ++ show frame + case frame of + (OfpFrame (OfpHeader _ _ _ xid) (OfptEchoRequest dat)) -> do + let resp = (OfpFrame (OfpHeader 1 0 0 xid) (OfptEchoReply dat)) + sendAll sock $ encode resp + putStrLn $ "TX: " ++ show resp + (OfpFrame (OfpHeader _ _ _ xid) (OfptPacketIn (OfpPacketIn bid len inp reason dat))) -> do + let resp = (OfpFrame (OfpHeader 1 0 0 xid) (OfptPacketOut (OfpPacketOut bid inp [(OfpOutput 6 0)] dat))) + sendAll sock $ encode resp + putStrLn $ "TX: " ++ show resp + _ -> putStrLn " UNHANDLED" + + +inp = 1 +outp = 6 +ofppController = 0xfffd +ofppNone = 0xffff + +pri = 1 +uint32max = 0xffffffff +emptyMac = MAC 0x00 0x00 0x00 0x00 0x00 0x00 +dlVlan' = 10 + +wc = [ + OfpfwInPort, + OfpfwDlVlan, + OfpfwDlSrc, + OfpfwDlDst, + OfpfwDlType, + OfpfwNwProto, + OfpfwTpSrc, + OfpfwTpDst, + OfpfwNwSrc, + OfpfwNwDst, + OfpfwDlVlanPcp, + OfpfwNwTos + ] + + +incrMac :: MAC -> Word64 -> MAC +incrMac (MAC a b c d e f) v = + MAC (fromIntegral $ (m `shiftR` 40) .&. 0xFF) + (fromIntegral $ (m `shiftR` 32) .&. 0xFF) + (fromIntegral $ (m `shiftR` 24) .&. 0xFF) + (fromIntegral $ (m `shiftR` 16) .&. 0xFF) + (fromIntegral $ (m `shiftR` 8) .&. 0xFF) + (fromIntegral $ m .&. 0xFF) + where + m = v + fromIntegral ((a `shiftL` 40) .|. + (b `shiftL` 32) .|. + (c `shiftL` 24) .|. + (d `shiftL` 16) .|. + (e `shiftL` 8) .|. f) + +flood :: Socket -> IO() +flood sock = flood' 4 0 + where + flood' 0 xid = putStrLn $ "done! xid=" ++ show xid + flood' n xid = do + let m = OfpMatch wc inp emptyMac (incrMac emptyMac n) dlVlan' 0 0 0 0 0 0 0 0 + let fm = OfpFlowMod m 0 OfpfcAdd 65535 65535 pri uint32max outp OfpffSendFlowRem [(OfpOutput outp 0)] + sendAll sock $ encode (OfpFrame (OfpHeader 1 0 0 xid) (OfptFlowMod fm)) + putStrLn $ "TX: " ++ show n + flood' (n-1) (xid+1) diff --git a/haskell-openflow.cabal b/haskell-openflow.cabal new file mode 100644 --- /dev/null +++ b/haskell-openflow.cabal @@ -0,0 +1,38 @@ +name: haskell-openflow +version: 0.0.0.1 +synopsis: OpenFlow protocol in Haskell +description: OpenFlow assists in network virtualization where multiple + isolated logical networks can share physical hardware. +category: Network +author: Brian Brooks +maintainer: brooks.brian@gmail.com +homepage: https://github.com/brooksbp/haskell-openflow +bug-reports: https://github.com/brooksbp/haskell-openflow/issues +license: BSD3 +license-file: LICENSE +cabal-version: >= 1.10 +build-type: Simple +extra-source-files: examples/echo-client.hs + ,examples/echo-server.hs + ,examples/server.hs + +library + build-depends: base >= 4 && < 5 + ,bytestring >= 0.9.2.1 + ,network >= 2.3.0.10 + ,network-info >= 0.2.0.3 + ,cereal >= 0.3.5.2 + exposed-modules: Network.OpenFlow + default-language: Haskell2010 + +test-suite test-main + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: base >= 4 && < 5, + haskell-openflow + hs-source-dirs: tests + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/brooksbp/haskell-openflow diff --git a/tests/Test.hs b/tests/Test.hs new file mode 100644 --- /dev/null +++ b/tests/Test.hs @@ -0,0 +1,7 @@ +module Main where + +import System.Exit + +main = do + putStrLn "Woot!" + exitSuccess