diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2010, Andreas Voellmy and Yale University +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +o Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +o 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. + +o Neither the name of the 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 OR CONTRIBUTORS 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +import Distribution.Simple + +main = defaultMain + diff --git a/nettle-openflow.cabal b/nettle-openflow.cabal new file mode 100644 --- /dev/null +++ b/nettle-openflow.cabal @@ -0,0 +1,56 @@ +Name: nettle-openflow +Version: 0.1 +Synopsis: High level configuration and control of computer networks. +Cabal-Version: >=1.2 +Build-Type: Simple +Stability: Experimental +Category: Network +License: BSD3 +License-file: LICENSE +Author: Andreas Voellmy, Ashish Agarwal, Sam Burnett, John Launchbury +Maintainer: andreas.voellmy@yale.edu + +Description: + This module provides a logical representation of the messages of the OpenFlow + protocol () and implements the binary formats + for these messages. This module also provides TCP servers that accept connections + from switches and provide methods to receive messages from and send messages to + connected switches. + The library is under active development and should still be considered experimental. + + +extra-source-files: src/Examples/SimpleImperativeIONetworkControl/NetLearningSwitch.hs + src/Examples/SimpleImperativeIONetworkControl/SimpleImperativeIONetworkControl.hs + +Library + hs-source-dirs: src + cpp-options: "-DOPENFLOW_VERSION=1" + exposed-modules: + Nettle.Ethernet.EthernetAddress + Nettle.Ethernet.EthernetFrame + Nettle.IPv4.IPAddress + Nettle.IPv4.IPPacket + Nettle.Servers.TCPServer + Nettle.Servers.MultiplexedTCPServer + Nettle.Servers.MessengerServer + Nettle.Servers.TwoWayChannel + Nettle.OpenFlow.Messages + Nettle.OpenFlow.Port + Nettle.OpenFlow.Action + Nettle.OpenFlow.Switch + Nettle.OpenFlow.Match + Nettle.OpenFlow.FlowTable + Nettle.OpenFlow.Packet + Nettle.OpenFlow.Statistics + Nettle.OpenFlow.Error + Nettle.OpenFlow.MessagesBinary + + build-depends: + base >= 4 && < 5 + , bytestring + , binary + , mtl + , parsec + , network + , containers + , bimap diff --git a/src/Examples/SimpleImperativeIONetworkControl/NetLearningSwitch.hs b/src/Examples/SimpleImperativeIONetworkControl/NetLearningSwitch.hs new file mode 100644 --- /dev/null +++ b/src/Examples/SimpleImperativeIONetworkControl/NetLearningSwitch.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE RecordWildCards #-} + +module Main where + +import Nettle.Servers.MultiplexedTCPServer +import Nettle.Servers.TCPServer +import SimpleImperativeIONetworkControl +import Nettle.OpenFlow.Messages as M +import Nettle.OpenFlow.Switch +import Nettle.OpenFlow.Port +import Nettle.OpenFlow.Packet +import Nettle.OpenFlow.Action +import Nettle.OpenFlow.FlowTable +import Nettle.OpenFlow.Match +import Nettle.Ethernet.EthernetAddress +import Nettle.Ethernet.EthernetFrame +import Nettle.IPv4.IPPacket +import Control.Monad.State +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Binary +import Data.Binary.Get +import Control.Monad.Error + + +type ControlState = (HostTable, SwitchState) +type SwitchState = Map.Map SockAddr SwitchFeatures + +{- Functions for getting and modifying the switch state. -} +switchFeatures :: SockAddr -> NetController ControlState (Maybe SwitchFeatures) +switchFeatures addr = gets snd >>= return . Map.lookup addr + +addSwitchFeatures :: SockAddr -> SwitchFeatures -> ControlState -> ControlState +addSwitchFeatures addr sfr (htbl,stbl) = (htbl, Map.insert addr sfr stbl) + +deleteSwitch :: SockAddr -> ControlState -> ControlState +deleteSwitch addr (htbl,stbl) = (htbl, Map.delete addr stbl) + + +{- +The host table mapps hosts to their known locations, i.e. to physical ports at OpenFlow switches. +-} + +type HostTable = Map.Map (EthernetAddress,SockAddr) PortID + +newHostTable = Map.empty + +learn :: EthernetAddress -> SockAddr -> PortID -> HostTable -> HostTable +learn hostAddr switchAddr portID = Map.insert (hostAddr, switchAddr) portID + +hostLookup :: EthernetAddress -> SockAddr -> HostTable -> Maybe PortID +hostLookup hostAddr switchAddr htbl = Map.lookup (hostAddr, switchAddr) htbl + +{- Convenience functions for manipulating state -} + +hostTableM :: NetController ControlState HostTable +hostTableM = gets fst + +learnM :: EthernetAddress -> SockAddr -> PortID -> NetController ControlState () +learnM addr dpid inPort = hostTableM >>= updateHostTableM . learn addr dpid inPort + +hostLookupM :: EthernetAddress -> SockAddr -> NetController ControlState (Maybe PortID) +hostLookupM hostAddr switchAddr = hostTableM >>= return . hostLookup hostAddr switchAddr + +updateHostTableM :: HostTable -> NetController ControlState () +updateHostTableM htbl = modify (\(_,swState) -> (htbl,swState)) + + + +{- The controller -} + +main = runNetController 2525 controller (newHostTable, Map.empty) + +controller :: NetController ControlState () +controller = mainHandler Set.empty + where mainHandler needHellos = + do e <- waitForEvent + case e of + ConnectionEstablished addr -> + do sendMessage addr 0 CSHello + mainHandler (Set.insert addr needHellos) + ConnectionTerminated addr e -> + do modify (deleteSwitch addr) + mainHandler (Set.delete addr needHellos) + PeerMessage addr (xid, msg) -> + if addr `Set.member` needHellos + then case msg of + SCHello -> do sendMessage addr 0 FeaturesRequest + mainHandler (Set.delete addr needHellos) + _ -> do liftIO $ putStrLn ("Expected to receive Hello from " ++ show addr ++ ", but received " ++ show msg) + else do case msg of + SCHello -> liftIO $ putStrLn ("Received unexpected hello from " ++ show addr ++ ".") + SCEchoRequest bytes -> sendMessage addr 0 (CSEchoReply bytes) + Features sfr -> modify (addSwitchFeatures addr sfr) + PacketIn pktInRecord -> handlePacketIn addr pktInRecord + _ -> liftIO $ putStrLn ("Unhandled message: " ++ show msg) + mainHandler needHellos + +handlePacketIn addr pktIn@(PacketInfo {..}) = + case runGetE getEthernetFrame packetData of + Left errorMessage -> liftIO $ putStrLn ("Failed to parse ethernet frame: " ++ errorMessage) + Right ethernetFrame -> + do learnM (sourceAddress ethernetFrame) addr receivedOnPort + if isReserved (sourceAddress ethernetFrame) + then sendMessage addr 0 $ M.FlowMod $ AddFlow { match = frameToExactMatch receivedOnPort ethernetFrame + , actions = [] + , priority = 0 + , idleTimeOut = ExpireAfter 60 + , hardTimeOut = Permanent + , applyToPacket = bufferID + , overlapAllowed = True + , notifyWhenRemoved = False + , cookie = 0 + } + else do mport <- hostLookupM (destAddress ethernetFrame) addr + case mport of + Nothing -> sendMessage addr 0 (M.PacketOut $ receivedPacketOut pktIn flood) + Just lprt -> do liftIO $ putStrLn $ "at addr: " ++ show addr ++ " forward to port " ++ show lprt + sendMessage addr 0 $ M.FlowMod $ AddFlow { match = frameToExactMatch receivedOnPort ethernetFrame + , actions = sendOnPort lprt + , priority = 0 + , idleTimeOut = ExpireAfter 60 + , hardTimeOut = Permanent + , applyToPacket = bufferID + , overlapAllowed = True + , notifyWhenRemoved = False + , cookie = 0 + } + sendMessage addr 0 $ M.PacketOut $ receivedPacketOut pktIn (sendOnPort lprt) + + + + + diff --git a/src/Examples/SimpleImperativeIONetworkControl/SimpleImperativeIONetworkControl.hs b/src/Examples/SimpleImperativeIONetworkControl/SimpleImperativeIONetworkControl.hs new file mode 100644 --- /dev/null +++ b/src/Examples/SimpleImperativeIONetworkControl/SimpleImperativeIONetworkControl.hs @@ -0,0 +1,31 @@ +module SimpleImperativeIONetworkControl where + +import Prelude hiding (catch) +import Control.Concurrent +import Control.Monad.State +import Control.Monad.Reader +import Nettle.OpenFlow.MessagesBinary +import Nettle.OpenFlow.Messages +import Nettle.Servers.MultiplexedTCPServer +import Nettle.Servers.TCPServer +import Control.Exception + +type NetController s a = ReaderT ChanEnv (StateT s IO) a +type ChanEnv = Process (TCPMessage (TransactionID, SCMessage)) (SockAddr, ((TransactionID, CSMessage))) IOException + +runNetController :: ServerPortNumber -> NetController s a -> s -> IO () +runNetController pstring netc s = do + netCh <- muxedTCPServer pstring messageDriver + chanFn netCh + where + chanFn netCh = do + runStateT (runReaderT netc netCh) s + return () + + +waitForEvent :: NetController s (TCPMessage (TransactionID, SCMessage)) +waitForEvent = ask >>= liftIO . readP + +sendMessage :: SockAddr -> TransactionID -> CSMessage -> NetController s () +sendMessage addr xid msg = ask >>= \p -> liftIO $ tellP p (addr, (xid, msg)) + diff --git a/src/Nettle/Ethernet/EthernetAddress.hs b/src/Nettle/Ethernet/EthernetAddress.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/Ethernet/EthernetAddress.hs @@ -0,0 +1,41 @@ +module Nettle.Ethernet.EthernetAddress ( + -- * Ethernet address + EthernetAddress(..) + , isReserved + + -- * Parsers and unparsers + , getEthernetAddress + , putEthernetAddress + ) where + +import Data.Word +import Data.Bits +import Data.Binary + +-- | An Ethernet address consists of 6 bytes. +data EthernetAddress = EthernetAddress Word8 Word8 Word8 Word8 Word8 Word8 + deriving (Show,Read,Eq,Ord) + +-- | Parse an Ethernet address from a ByteString +getEthernetAddress :: Get EthernetAddress +getEthernetAddress = + do a1 <- get + a2 <- get + a3 <- get + a4 <- get + a5 <- get + a6 <- get + return $ EthernetAddress a1 a2 a3 a4 a5 a6 + +-- | Unparse an Ethernet address to a ByteString +putEthernetAddress :: EthernetAddress -> Put +putEthernetAddress (EthernetAddress a1 a2 a3 a4 a5 a6) = put a1 >> put a2 >> put a3 >> put a4 >> put a5 >> put a6 + +isReserved :: EthernetAddress -> Bool +isReserved (EthernetAddress a1 a2 a3 a4 a5 a6) = + a1 == 0x01 && + a2 == 0x80 && + a3 == 0xc2 && + a4 == 0 && + ((a5 .&. 0xf0) == 0) + diff --git a/src/Nettle/Ethernet/EthernetFrame.hs b/src/Nettle/Ethernet/EthernetFrame.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/Ethernet/EthernetFrame.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | This module provides data structures for Ethernet frames +-- as well as parsers and unparsers for Ethernet frames. +module Nettle.Ethernet.EthernetFrame ( + + -- * Data types + EthernetFrame(..) + , EthernetHeader(..) + , EthernetTypeCode + , ethTypeVLAN + , ethTypeIP + , ethTypeARP + , ethTypeLLDP + , typeEth2Cutoff + , VLANPriority + , VLANID + , EthernetBody(..) + , ARPPacket(..) + , ARPOpCode(..) + + -- * Parsers and unparsers + , GetE + , ErrorMessage + , runGetE + , getEthernetFrame + , getEthHeader + , putEthHeader + , getARPPacket + ) where + +import Nettle.Ethernet.EthernetAddress +import Nettle.IPv4.IPPacket +import Nettle.IPv4.IPAddress +import qualified Data.ByteString.Lazy as B +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.Word +import Data.Bits +import Control.Monad +import Control.Monad.Error + +-- It was based on http://en.wikipedia.org/wiki/File:Ethernet_Type_II_Frame_format.svg + +-- | An Ethernet frame consists of an Ethernet header and an Ethernet body. +data EthernetFrame = EthernetFrame EthernetHeader EthernetBody + deriving (Show,Eq) + +data EthernetHeader = EthernetHeader { destMACAddress :: EthernetAddress, + sourceMACAddress :: EthernetAddress, + typeCode :: EthernetTypeCode } + | Ethernet8021Q { destMACAddress :: EthernetAddress, + sourceMACAddress :: EthernetAddress, + typeCode :: EthernetTypeCode, + priorityCodePoint :: VLANPriority, + canonicalFormatIndicator :: Bool, + vlanId :: VLANID } + deriving (Read,Show,Eq) + +type VLANPriority = Word8 + +-- | Ethernet type code, determines the type of payload carried by an Ethernet frame. +type EthernetTypeCode = Word16 + +type VLANID = Word16 + +-- | The body of an Ethernet frame is either an IP packet, an ARP packet, or an uninterpreted @ByteString@ +data EthernetBody = IPInEthernet IPPacket + | ARPInEthernet ARPPacket + | UninterpretedEthernetBody B.ByteString + deriving (Show,Eq) + +instance FramedMessage EthernetFrame EthernetAddress EthernetBody where + body (EthernetFrame _ b) = b + sourceAddress (EthernetFrame hdr _) = sourceMACAddress hdr + destAddress (EthernetFrame hdr _) = destMACAddress hdr + +-- | An ARP packet +data ARPPacket = ARPPacket { arpOpCode :: ARPOpCode + , senderEthernetAddress :: EthernetAddress + , senderIPAddress :: IPAddress + , targetEthernetAddress :: EthernetAddress + , targetIPAddress :: IPAddress + } deriving (Show,Eq) + +-- | Type of ARP message. +data ARPOpCode = ARPRequest + | ARPReply deriving (Show,Eq) + +-- | Type of parsers that can fail with an error message +type GetE a = ErrorT ErrorMessage Get a + +-- | When a @GetE@ parser fails, it provides an error message as a string +type ErrorMessage = String + +-- | Method to run a @GetE@ parser +runGetE :: GetE a -> B.ByteString -> Either ErrorMessage a +runGetE g = runGet (runErrorT g) + +-- | Parser for Ethernet frames. +getEthernetFrame :: GetE EthernetFrame +getEthernetFrame = do + hdr <- getEthHeader + if typeCode hdr == ethTypeIP + then do ipPacket <- lift getIPPacket + return $ EthernetFrame hdr (IPInEthernet ipPacket) + else if typeCode hdr == ethTypeARP + then do arpPacket <- getARPPacket + return (EthernetFrame hdr (ARPInEthernet arpPacket)) + else do body <- lift getRemainingLazyByteString + return $ EthernetFrame hdr (UninterpretedEthernetBody body) + +-- | Parser for Ethernet headers. +getEthHeader :: GetE EthernetHeader +getEthHeader = do + dstAddr <- lift getEthernetAddress + srcAddr <- lift getEthernetAddress + tcode <- lift getWord16be + if tcode < typeEth2Cutoff + then throwError ("tcode of ethernet header is not greater than " ++ show typeEth2Cutoff) + else if (tcode == ethTypeVLAN) + then do x <- lift getWord16be + etherType <- lift getWord16be + let pcp = fromIntegral (shiftR x 13) + let cfi = testBit x 12 + let vid = clearBits x [12,13,14,15] + return (Ethernet8021Q dstAddr srcAddr etherType pcp cfi vid) + else return (EthernetHeader dstAddr srcAddr tcode) + +-- | Unparser for Ethernet headers. +putEthHeader :: EthernetHeader -> Put +putEthHeader (EthernetHeader dstAddr srcAddr tcode) = + do putEthernetAddress dstAddr + putEthernetAddress srcAddr + putWord16be tcode +putEthHeader (Ethernet8021Q dstAddr srcAddr tcode pcp cfi vid) = + do putEthernetAddress dstAddr + putEthernetAddress srcAddr + putWord16be ethTypeVLAN + putWord16be x + putWord16be tcode + where x = let y = shiftL (fromIntegral pcp :: Word16) 13 + y' = if cfi then setBit y 12 else y + in y' + fromIntegral vid + + + +ethTypeIP, ethTypeARP, ethTypeLLDP, ethTypeVLAN, typeEth2Cutoff :: EthernetTypeCode +ethTypeIP = 0x0800 +ethTypeARP = 0x0806 +ethTypeLLDP = 0x88CC +ethTypeVLAN = 0x8100 +typeEth2Cutoff = 0x0600 + + +-- | Parser for ARP packets +getARPPacket :: GetE ARPPacket +getARPPacket = do + htype <- lift getWord16be + ptype <- lift getWord16be + hlen <- lift getWord8 + plen <- lift getWord8 + opCode <- getARPOpCode + sha <- lift getEthernetAddress + spa <- lift getIPAddress + tha <- lift getEthernetAddress + tpa <- lift getIPAddress + return (ARPPacket { arpOpCode = opCode, + senderEthernetAddress = sha, + senderIPAddress = spa, + targetEthernetAddress = tha, + targetIPAddress = tpa }) + +getARPOpCode :: GetE ARPOpCode +getARPOpCode = do + op <- lift getWord16be + if op == 1 + then return ARPRequest + else if op == 2 + then return ARPReply + else throwError ("Unrecognized ARP opcode: " ++ show op) + +clearBits :: Bits a => a -> [Int] -> a +clearBits = foldl clearBit + diff --git a/src/Nettle/IPv4/IPAddress.hs b/src/Nettle/IPv4/IPAddress.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/IPv4/IPAddress.hs @@ -0,0 +1,112 @@ +module Nettle.IPv4.IPAddress where + +import Data.Word +import Data.Bits +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Text.ParserCombinators.Parsec +import Data.Maybe + +newtype IPAddress = IPAddress Word32 deriving (Read, Eq, Show, Ord) +type IPAddressPrefix = (IPAddress, PrefixLength) +type PrefixLength = Word8 + +ipAddressToWord32 :: IPAddress -> Word32 +ipAddressToWord32 (IPAddress a) = a + +ipAddress :: Word8 -> Word8 -> Word8 -> Word8 -> IPAddress +ipAddress b1 b2 b3 b4 = + IPAddress $ foldl (\a b -> shift a 8 + fromIntegral b) (0 :: Word32) [b1,b2,b3,b4] + +instance Binary IPAddress where + get = getIPAddress + put = putIPAddress + +getIPAddress :: Get IPAddress +getIPAddress = getWord32be >>= return . IPAddress + +putIPAddress :: IPAddress -> Put +putIPAddress (IPAddress a) = putWord32be a + +(//) :: IPAddress -> PrefixLength -> IPAddressPrefix +(IPAddress a) // len = (IPAddress a', len) + where a' = a .&. mask + mask = foldl setBit (0 :: Word32) [(32-fromIntegral len)..31] + +addressPart :: IPAddressPrefix -> IPAddress +addressPart (IPAddress a,l) = + IPAddress (a .&. shiftL (ones l) (fromIntegral maxPrefixLen - fromIntegral l)) + where ones j = shiftL (1 :: Word32) (fromIntegral j) - 1 + +prefixLength :: IPAddressPrefix -> PrefixLength +prefixLength (_,l) = l + +maxPrefixLen :: Word8 +maxPrefixLen = 32 + +prefixIsExact :: IPAddressPrefix -> Bool +prefixIsExact (_,l) = l==maxPrefixLen + +defaultIPPrefix = ipAddress 0 0 0 0 // 0 + +addressToOctets :: IPAddress -> (Word8, Word8, Word8, Word8) +addressToOctets (IPAddress addr) = (b1,b2,b3,b4) + where b4 = fromIntegral $ addr .&. (2^8 - 1) + b3 = fromIntegral $ shiftR (addr .&. (2^16 - 1)) 8 + b2 = fromIntegral $ shiftR (addr .&. (2^24 - 1)) 16 + b1 = fromIntegral $ shiftR (addr .&. (2^32 - 1)) 24 + +showOctets :: IPAddress -> String +showOctets addr = show b1 ++ "." ++ show b2 ++ "." ++ show b3 ++ "." ++ show b4 + where (b1,b2,b3,b4) = addressToOctets addr + +showPrefix :: IPAddressPrefix -> String +showPrefix (addr, len) = showOctets addr ++ "/" ++ show len + +prefixPlus :: IPAddressPrefix -> Word32 -> IPAddress +prefixPlus (IPAddress addr,_) x = IPAddress (addr + x) + +prefixOverlaps :: IPAddressPrefix -> IPAddressPrefix -> Bool +prefixOverlaps p1@(IPAddress addr, len) p2@(IPAddress addr', len') + | addr .&. mask == addr' .&. mask = True + | otherwise = False + where len'' = min len len' + mask = foldl setBit (0 :: Word32) [(32 - fromIntegral len'')..31] + +elemOfPrefix :: IPAddress -> IPAddressPrefix -> Bool +elemOfPrefix addr prefix = (addr // 32) `prefixOverlaps` prefix + +intersect :: IPAddressPrefix -> IPAddressPrefix -> Maybe IPAddressPrefix +intersect p1@(_, len1) p2@(_, len2) + | p1 `prefixOverlaps` p2 = Just longerPrefix + | otherwise = Nothing + where longerPrefix = if len1 < len2 then p2 else p1 + +intersects :: [IPAddressPrefix] -> Maybe IPAddressPrefix +intersects = foldl f (Just defaultIPPrefix) + where f mpref pref = maybe Nothing (intersect pref) mpref + +disjoint :: IPAddressPrefix -> IPAddressPrefix -> Bool +disjoint p1 p2 = not (p1 `prefixOverlaps` p2) + +disjoints :: [IPAddressPrefix] -> Bool +disjoints = isNothing . intersects + +isSubset :: IPAddressPrefix -> IPAddressPrefix -> Bool +isSubset p1@(_,l) p2@(_,l') = l <= l' && (p1 `prefixOverlaps` p2) + +parseIPAddress :: String -> Maybe IPAddress +parseIPAddress s = case parse ipAddressParser "" s of + Right a -> Just a + Left _ -> Nothing + +ipAddressParser :: CharParser () IPAddress +ipAddressParser = do a <- many1 digit + char '.' + b <- many1 digit + char '.' + c <- many1 digit + char '.' + d <- many1 digit + return $ ipAddress (read a) (read b) (read c) (read d) diff --git a/src/Nettle/IPv4/IPPacket.hs b/src/Nettle/IPv4/IPPacket.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/IPv4/IPPacket.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, RecordWildCards #-} + +{-| + +This module provides @Get@ values for parsing various +IP packets and headers from ByteStrings into a byte-sequence-independent +representation as Haskell datatypes. + +Warning: + +These are incomplete. The headers may not contain all the information +that the protocols specify. For example, the Haskell representation of an IP Header +only includes source and destination addresses and IP protocol number, even though +an IP packet has many more header fields. More seriously, an IP header may have an optional +extra headers section after the destination address. We assume this is not present. If it is present, +then the transport protocol header will not be directly after the destination address, but will be after +these options. Therefore functions that assume this, such as the getExactMatch function below, will give +incorrect results when applied to such IP packets. + +The Haskell representations of the headers for the transport protocols are similarly incomplete. +Again, the Get instances for the transport protocols may not parse through the end of the +transport protocol header. + +-} +module Nettle.IPv4.IPPacket ( + -- * IP Packet + IPPacket(..) + , IPHeader(..) + , DifferentiatedServicesCodePoint + , FragOffset + , IPProtocol + , IPTypeOfService + , TransportPort + , ipTypeTcp + , ipTypeUdp + , ipTypeIcmp + , IPBody(..) + + -- * Parsers + , getIPPacket + , getIPHeader + , ICMPHeader + , ICMPType + , ICMPCode + , getICMPHeader + , TCPHeader + , TCPPortNumber + , getTCPHeader + , UDPHeader + , UDPPortNumber + , getUDPHeader + + -- * Framed Messages + , FramedMessage(..) + + ) where + +import Nettle.IPv4.IPAddress +import Data.Bits +import Data.Word +import Data.Binary +import Data.Binary.Get +import qualified Data.ByteString.Lazy as B + +-- | An IP packet consists of a header and a body. +data IPPacket = IPPacket IPHeader IPBody + deriving (Show,Eq) + +-- | An IP Header includes various information about the packet, including the type of payload it contains. +-- Warning: this definition does not include every header field included in an IP packet. +data IPHeader = IPHeader { ipSrcAddress :: IPAddress + , ipDstAddress :: IPAddress + , ipProtocol :: IPProtocol + , headerLength :: Int + , totalLength :: Int + , dscp :: DifferentiatedServicesCodePoint -- ^ differentiated services code point - 6 bit number + } + deriving (Read,Show,Eq) + +type DifferentiatedServicesCodePoint = Word8 +type FragOffset = Word16 +type IPProtocol = Word8 +type IPTypeOfService = Word8 +type TransportPort = Word16 + +ipTypeTcp, ipTypeUdp, ipTypeIcmp :: IPProtocol + +ipTypeTcp = 6 +ipTypeUdp = 17 +ipTypeIcmp = 1 + +-- | The body of an IP packet can be either a TCP, UDP, ICMP or other packet. +-- Packets other than TCP, UDP, ICMP are represented as unparsed @ByteString@ values. +data IPBody = TCPInIP TCPHeader + | UDPInIP UDPHeader + | ICMPInIP ICMPHeader + | UninterpretedIPBody B.ByteString + deriving (Show,Eq) + +-- | The @FramedMessage@ class defines the class of data types +-- which represents messages having source and destination addresses +-- and a message body. +class FramedMessage m a b | m -> a, m -> b where + body :: m -> b + sourceAddress :: m -> a + destAddress :: m -> a + +instance FramedMessage IPPacket IPAddress IPBody where + body (IPPacket _ b) = b + sourceAddress (IPPacket hdr _) = ipSrcAddress hdr + destAddress (IPPacket hdr _) = ipDstAddress hdr + + +getIPHeader :: Get IPHeader +getIPHeader = do + b1 <- getWord8 + diffServ <- getWord8 + totalLen <- getWord16be + ident <- getWord16be + flagsAndFragOffset <- getWord16be + ttl <- getWord8 + nwproto <- getIPProtocol + hdrChecksum <- getWord16be + nwsrc <- getIPAddress + nwdst <- getIPAddress + return (IPHeader { ipSrcAddress = nwsrc + , ipDstAddress = nwdst + , ipProtocol = nwproto + , headerLength = fromIntegral (b1 .&. 0x0f) + , totalLength = fromIntegral totalLen + , dscp = shiftR diffServ 2 + } ) + +getIPProtocol :: Get IPProtocol +getIPProtocol = getWord8 + +getFragOffset :: Get FragOffset +getFragOffset = getWord16be + +getIPPacket :: Get IPPacket +getIPPacket = do + hdr <- getIPHeader + body <- getIPBody hdr + return (IPPacket hdr body) + where getIPBody (IPHeader {..}) + | ipProtocol == ipTypeTcp = getTCPHeader >>= return . TCPInIP + | ipProtocol == ipTypeUdp = getUDPHeader >>= return . UDPInIP + | ipProtocol == ipTypeIcmp = getICMPHeader >>= return . ICMPInIP + | otherwise = getLazyByteString (fromIntegral (totalLength - headerLength)) >>= + return . UninterpretedIPBody + +-- Transport Header + +type ICMPHeader = (ICMPType, ICMPCode) +type ICMPType = Word8 +type ICMPCode = Word8 + +getICMPHeader :: Get ICMPHeader +getICMPHeader = do + icmp_type <- getWord8 + icmp_code <- getWord8 + skip 6 + return (icmp_type, icmp_code) + +type TCPHeader = (TCPPortNumber, TCPPortNumber) +type TCPPortNumber = Word16 + +getTCPHeader :: Get TCPHeader +getTCPHeader = do + srcp <- getWord16be + dstp <- getWord16be + return (srcp,dstp) + +type UDPHeader = (UDPPortNumber, UDPPortNumber) +type UDPPortNumber = Word16 + +getUDPHeader :: Get UDPHeader +getUDPHeader = do + srcp <- getWord16be + dstp <- getWord16be + return (srcp,dstp) + diff --git a/src/Nettle/OpenFlow/Action.hs b/src/Nettle/OpenFlow/Action.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/OpenFlow/Action.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE CPP #-} + +module Nettle.OpenFlow.Action ( + -- * Actions + Action (..) + , ActionType (..) + , PseudoPort (..) + , MaxLenToSendController +#if OPENFLOW_VERSION==1 + , VendorID + , QueueID +#endif + -- * Action sequences + , ActionSequence(..) + , sendOnPort, sendOnInPort, flood, drop, allPhysicalPorts, processNormally, sendToController, processWithTable + , setVlanVID, setVlanPriority, stripVlanHeader, setEthSrcAddr, setEthDstAddr + , setIPSrcAddr, setIPDstAddr +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + , setIPToS +#endif + , setTransportSrcPort + , setTransportDstPort +#if OPENFLOW_VERSION==1 + , enqueue + , vendorAction +#endif + + ) where + +import Prelude hiding (drop) +import Nettle.OpenFlow.Port +import Nettle.Ethernet.EthernetAddress +import Nettle.Ethernet.EthernetFrame +import Nettle.IPv4.IPAddress +import Nettle.IPv4.IPPacket +import Data.Word + + +-- |The supported switch actions are denoted with these symbols. +data ActionType = OutputToPortType + | SetVlanVIDType + | SetVlanPriorityType + | StripVlanHeaderType + | SetEthSrcAddrType + | SetEthDstAddrType + | SetIPSrcAddrType + | SetIPDstAddrType +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + | SetIPTypeOfServiceType +#endif + | SetTransportSrcPortType + | SetTransportDstPortType +#if OPENFLOW_VERSION==1 + | EnqueueType +#endif + | VendorActionType + deriving (Show,Read,Eq,Ord,Enum) + +-- | Each flow table entry contains a list of actions that will +-- be executed when a packet matches the entry. +-- Specification: @ofp_action_header@ and all @ofp_action_*@ structures. +data Action + = SendOutPort PseudoPort -- ^send out given port + | SetVlanVID VLANID -- ^set the 802.1q VLAN ID + | SetVlanPriority VLANPriority -- ^set the 802.1q priority + | StripVlanHeader -- ^strip the 802.1q header + | SetEthSrcAddr EthernetAddress -- ^set ethernet source address + | SetEthDstAddr EthernetAddress -- ^set ethernet destination address + | SetIPSrcAddr IPAddress -- ^set IP source address + | SetIPDstAddr IPAddress -- ^set IP destination address +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + | SetIPToS IPTypeOfService -- ^IP ToS (DSCP field) +#endif + | SetTransportSrcPort TransportPort -- ^set TCP/UDP source port + | SetTransportDstPort TransportPort -- ^set TCP/UDP destination port +#if OPENFLOW_VERSION==1 + | Enqueue { + enqueuePort :: PortID, -- ^port the queue belongs to + queueID :: QueueID -- ^where to enqueue the packets + } -- ^output to queue + | VendorAction VendorID [Word8] +#endif + deriving (Show,Eq) + + +-- | A @PseudoPort@ denotes the target of a forwarding +-- action. +data PseudoPort = PhysicalPort PortID -- ^send out physical port with given id + | InPort -- ^send packet out the input port + | Flood -- ^send out all physical ports except input port and those disabled by STP + | AllPhysicalPorts -- ^send out all physical ports except input port + | ToController MaxLenToSendController -- ^send to controller + | NormalSwitching -- ^process with normal L2/L3 switching + | WithTable -- ^process packet with flow table + deriving (Show,Read, Eq) + +-- | A send to controller action includes the maximum +-- number of bytes that a switch will send to the +-- controller. +type MaxLenToSendController = Word16 + +#if OPENFLOW_VERSION==1 +type VendorID = Word32 +type QueueID = Word32 +#endif + +-- | Sequence of actions, represented as finite lists. The Monoid instance of +-- lists provides methods for denoting the do-nothing action (@mempty@) and for concatenating action sequences @mconcat@. +type ActionSequence = [Action] + +-- | send p is a packet send action. +send :: PseudoPort -> ActionSequence +send p = [SendOutPort p] + +sendOnPort :: PortID -> ActionSequence +sendOnPort p = [SendOutPort $ PhysicalPort p] + +sendOnInPort, flood, drop, allPhysicalPorts, processNormally :: ActionSequence +sendOnInPort = send InPort +flood = send Flood +drop = [] +allPhysicalPorts = send AllPhysicalPorts +processNormally = send NormalSwitching +processWithTable = send WithTable + +sendToController :: MaxLenToSendController -> ActionSequence +sendToController maxlen = send (ToController maxlen) + +setVlanVID :: VLANID -> ActionSequence +setVlanVID vlanid = [SetVlanVID vlanid] + +setVlanPriority :: VLANPriority -> ActionSequence +setVlanPriority x = [SetVlanPriority x] + +stripVlanHeader :: ActionSequence +stripVlanHeader = [StripVlanHeader] + +setEthSrcAddr :: EthernetAddress -> ActionSequence +setEthSrcAddr addr = [SetEthSrcAddr addr] + +setEthDstAddr :: EthernetAddress -> ActionSequence +setEthDstAddr addr = [SetEthDstAddr addr] + +setIPSrcAddr :: IPAddress -> ActionSequence +setIPSrcAddr addr = [SetIPSrcAddr addr] + +setIPDstAddr :: IPAddress -> ActionSequence +setIPDstAddr addr = [SetIPDstAddr addr] + +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 +setIPToS :: IPTypeOfService -> ActionSequence +setIPToS tos = [SetIPToS tos] +#endif + +setTransportSrcPort :: TransportPort -> ActionSequence +setTransportSrcPort port = [SetTransportSrcPort port] + +setTransportDstPort :: TransportPort -> ActionSequence +setTransportDstPort port = [SetTransportDstPort port] + + +#if OPENFLOW_VERSION==1 +enqueue :: PortID -> QueueID -> ActionSequence +enqueue portid queueid = [Enqueue portid queueid] + +vendorAction :: VendorID -> [Word8] -> ActionSequence +vendorAction vid bytes = [VendorAction vid bytes] +#endif + + + diff --git a/src/Nettle/OpenFlow/Error.hs b/src/Nettle/OpenFlow/Error.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/OpenFlow/Error.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE CPP #-} + +module Nettle.OpenFlow.Error ( + SwitchError (..) + , HelloFailure (..) + , RequestError (..) + , ActionError (..) + , FlowModError (..) + , PortModError (..) +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + , QueueOpError (..) +#endif + ) where + +import Data.Word + +-- | When a switch encounters an error condition, it sends the controller +-- a message containing the information in @SwitchErrorRecord@. +data SwitchError = HelloFailed HelloFailure String + | BadRequest RequestError [Word8] +#if OPENFLOW_VERSION==151 + | BadAction Word16 [Word8] + | FlowModFailed Word16 [Word8] +#endif +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + | BadAction ActionError [Word8] + | FlowModFailed FlowModError [Word8] + | PortModFailed PortModError [Word8] + | QueueOperationFailed QueueOpError [Word8] +#endif + deriving (Show, Eq) + +data HelloFailure = IncompatibleVersions +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + | HelloPermissionsError +#endif + deriving (Show, Eq, Ord, Enum) + +data RequestError = VersionNotSupported + | MessageTypeNotSupported + | StatsRequestTypeNotSupported + | VendorNotSupported + | VendorSubtypeNotSupported + | RequestPermissionsError +#if OPENFLOW_VERSION==1 + | BadRequestLength + | BufferEmpty + | UnknownBuffer +#endif + deriving (Show, Eq, Ord, Enum) + + +data ActionError = UnknownActionType + | BadActionLength + | UnknownVendorID + | UnknownActionTypeForVendor + | BadOutPort + | BadActionArgument +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + | ActionPermissionsError +#endif +#if OPENFLOW_VERSION==1 + | TooManyActions + | InvalidQueue +#endif + deriving (Show, Eq, Ord, Enum) + +data FlowModError = TablesFull + | OverlappingFlow + | FlowModPermissionsError + | EmergencyModHasTimeouts +#if OPENFLOW_VERSION==1 + | BadCommand + | UnsupportedActionList +#endif + deriving (Show, Eq, Ord, Enum) + +data PortModError = BadPort | BadHardwareAddress deriving (Show, Eq, Ord, Enum) + +data QueueOpError = QueueOpBadPort | QueueDoesNotExist | QueueOpPermissionsError deriving (Show, Eq, Ord, Enum) + diff --git a/src/Nettle/OpenFlow/FlowTable.hs b/src/Nettle/OpenFlow/FlowTable.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/OpenFlow/FlowTable.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE CPP, DisambiguateRecordFields #-} +-- | A switch has some number of flow tables. Each flow table is a +-- prioritized list of entries containing a @Match@, a list of +-- @Action@s, and other options affecting the behavior of the switch. +-- This module represents the OpenFlow messages that can be used +-- to modify flow tables. +module Nettle.OpenFlow.FlowTable ( + FlowTableID + , FlowMod (..) +#if OPENFLOW_VERSION==1 + , Cookie +#endif + , Priority + , TimeOut (..) + , FlowRemoved (..) + , FlowRemovalReason (..) + ) where + +import Nettle.OpenFlow.Switch +import Nettle.OpenFlow.Action +import Nettle.OpenFlow.Match +import Nettle.OpenFlow.Packet +import Data.Word +import Data.List as List + +type FlowTableID = Word8 + +data FlowMod = AddFlow { match :: Match + , priority :: Priority + , actions :: ActionSequence +#if OPENFLOW_VERSION==1 + , cookie :: Cookie +#endif + , idleTimeOut :: TimeOut + , hardTimeOut :: TimeOut +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + , notifyWhenRemoved :: Bool +#endif + , applyToPacket :: Maybe BufferID +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + , overlapAllowed :: Bool +#endif + } + | AddEmergencyFlow { match :: Match + , priority :: Priority + , actions :: ActionSequence +#if OPENFLOW_VERSION==1 + , cookie :: Cookie +#endif +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + , overlapAllowed :: Bool +#endif + } + + | ModifyFlows { match :: Match + , newActions :: ActionSequence + , ifMissingPriority :: Priority +#if OPENFLOW_VERSION==1 + , ifMissingCookie :: Cookie +#endif + , ifMissingIdleTimeOut :: TimeOut + , ifMissingHardTimeOut :: TimeOut +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + , ifMissingNotifyWhenRemoved :: Bool + , ifMissingOverlapAllowed :: Bool +#endif + } + | ModifyExactFlow { match :: Match + , priority :: Priority + , newActions :: ActionSequence +#if OPENFLOW_VERSION==1 + , ifMissingCookie :: Cookie +#endif + , ifMissingIdleTimeOut :: TimeOut + , ifMissingHardTimeOut :: TimeOut +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + , ifMissingNotifyWhenRemoved :: Bool + , ifMissingOverlapAllowed :: Bool +#endif + } + | DeleteFlows { match :: Match, + outPort :: Maybe PseudoPort + } + | DeleteExactFlow { match :: Match, + outPort :: Maybe PseudoPort, + priority :: Priority + } + + deriving (Show, Eq) + + +#if OPENFLOW_VERSION==1 +type Cookie = Word64 +#endif + +-- |The priority of a flow entry is a 16-bit integer. Flow entries with higher numeric priorities match before lower ones. +type Priority = Word16 + +-- | Each flow entry has idle and hard timeout values +-- associated with it. +data TimeOut = Permanent + | ExpireAfter Word16 + deriving (Show,Eq) + + +-- | When a switch removes a flow, it may send a message containing the information +-- in @FlowRemovedRecord@ to the controller. +#if OPENFLOW_VERSION==151 +data FlowRemoved = FlowRemoved { flowRemovedMatch :: Match, + flowRemovedPriority :: Priority, + flowRemovedReason :: FlowRemovalReason, + flowRemovedDuration :: Integer, + flowRemovedPacketCount :: Integer, + flowRemovedByteCount :: Integer } + deriving (Show,Eq) +#endif +#if OPENFLOW_VERSION==152 +data FlowRemoved = FlowRemoved { flowRemovedMatch :: Match, + flowRemovedPriority :: Priority, + flowRemovedReason :: FlowRemovalReason, + flowRemovedDuration :: Integer, + flowRemovedIdleTimeout :: Integer, + flowRemovedPacketCount :: Integer, + flowRemovedByteCount :: Integer } + deriving (Show,Eq) +#endif +#if OPENFLOW_VERSION==1 +data FlowRemoved = FlowRemoved { flowRemovedMatch :: Match, + flowRemovedCookie :: Word64, + flowRemovedPriority :: Priority, + flowRemovedReason :: FlowRemovalReason, + flowRemovedDuration :: Integer, + flowRemovedDurationNSecs :: Integer, + flowRemovedIdleTimeout :: Integer, + flowRemovedPacketCount :: Integer, + flowRemovedByteCount :: Integer } + deriving (Show,Eq) +#endif + +data FlowRemovalReason = IdleTimerExpired + | HardTimerExpired +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + | DeletedByController +#endif + deriving (Show,Eq,Ord,Enum) diff --git a/src/Nettle/OpenFlow/Match.hs b/src/Nettle/OpenFlow/Match.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/OpenFlow/Match.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE CPP, DisambiguateRecordFields, RecordWildCards, NamedFieldPuns #-} + +module Nettle.OpenFlow.Match ( + Match (..) + , matchAny + , isExactMatch + , getExactMatch + , frameToExactMatch + , ofpVlanNone + , matches + ) where + +import Nettle.Ethernet.EthernetAddress +import Nettle.Ethernet.EthernetFrame +import Nettle.IPv4.IPAddress +import qualified Nettle.IPv4.IPPacket as IP +import Nettle.OpenFlow.Port +import Data.Maybe (isJust) +import Data.Binary +import Control.Monad.Error + +-- | Each flow entry includes a match, which essentially defines packet-matching condition. +-- Fields that are left Nothing are "wildcards". +data Match = Match { inPort :: Maybe PortID, + srcEthAddress, dstEthAddress :: Maybe EthernetAddress, + vLANID :: Maybe VLANID, +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + vLANPriority :: Maybe VLANPriority, +#endif + ethFrameType :: Maybe EthernetTypeCode, +#if OPENFLOW_VERSION==1 + ipTypeOfService :: Maybe IP.IPTypeOfService, +#endif + ipProtocol :: Maybe IP.IPProtocol, + srcIPAddress, dstIPAddress :: IPAddressPrefix, + srcTransportPort, dstTransportPort :: Maybe IP.TransportPort } + deriving (Show,Read,Eq) + + +-- |A match that matches every packet. +matchAny :: Match +matchAny = Match { inPort = Nothing, + srcEthAddress = Nothing, + dstEthAddress = Nothing, + vLANID = Nothing, +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + vLANPriority = Nothing, +#endif + ethFrameType = Nothing, +#if OPENFLOW_VERSION==1 + ipTypeOfService = Nothing, +#endif + ipProtocol = Nothing, + srcIPAddress = defaultIPPrefix, + dstIPAddress = defaultIPPrefix, + srcTransportPort = Nothing, + dstTransportPort = Nothing } + +-- | Return True if given 'Match' represents an exact match, i.e. no +-- wildcards and the IP addresses' prefixes cover all bits. +isExactMatch :: Match -> Bool +isExactMatch (Match {..}) = + (isJust inPort) && + (isJust srcEthAddress) && + (isJust dstEthAddress) && + (isJust vLANID) && +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + (isJust vLANPriority) && +#endif + (isJust ethFrameType) && +#if OPENFLOW_VERSION==1 + (isJust ipTypeOfService) && +#endif + (isJust ipProtocol) && + (prefixIsExact srcIPAddress) && + (prefixIsExact dstIPAddress) && + (isJust srcTransportPort) && + (isJust dstTransportPort) + +ofpVlanNone = 0xffff + +frameToExactMatch :: PortID -> EthernetFrame -> Match +frameToExactMatch inPort frame = + addEthConditions frame (matchAny { inPort = Just inPort }) + where addEthConditions (EthernetFrame ethHdr ethBody) m = + let m1 = case ethHdr of + Ethernet8021Q {..} -> + m { srcEthAddress = Just sourceMACAddress + , dstEthAddress = Just destMACAddress + , vLANID = Just vlanId + , ethFrameType = Just typeCode +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + , vLANPriority = Just priorityCodePoint +#endif + } + EthernetHeader {..} -> + m { srcEthAddress = Just sourceMACAddress + , dstEthAddress = Just destMACAddress + , ethFrameType = Just typeCode + , vLANID = Just (fromIntegral ofpVlanNone) +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + , vLANPriority = Just 0 +#endif + } + in case ethBody of + IPInEthernet (IP.IPPacket (IP.IPHeader {..}) ipBody) -> + let m2 = m1 { ipProtocol = Just ipProtocol + , srcIPAddress = ipSrcAddress // 32 + , dstIPAddress = ipDstAddress // 32 +#if OPENFLOW_VERSION==1 + , ipTypeOfService = Just dscp +#endif + } + in case ipBody of + IP.TCPInIP (src,dst) -> m2 { srcTransportPort = Just src, + dstTransportPort = Just dst } + IP.UDPInIP (src,dst) -> m2 { srcTransportPort = Just src, + dstTransportPort = Just dst } + IP.ICMPInIP (icmpType,icmpCode) -> m2 { srcTransportPort = Just (fromIntegral icmpType), + dstTransportPort = Just 0 } + IP.UninterpretedIPBody _ -> m2 + + ARPInEthernet (ARPPacket {..}) -> + m1 { ipProtocol = Just ( if arpOpCode == ARPRequest then 1 else 2) + , srcIPAddress = senderIPAddress // 32 + , dstIPAddress = targetIPAddress // 32 + } + UninterpretedEthernetBody _ -> m1 + + +-- | Utility function to get an exact match corresponding to +-- a packet (as given by a byte sequence). +getExactMatch :: PortID -> GetE Match +getExactMatch inPort = do + frame <- getEthernetFrame + return (frameToExactMatch inPort frame) + + +-- | Models the match semantics of an OpenFlow switch. +matches :: (PortID, EthernetFrame) -> Match -> Bool +#if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152 +matches (inPort, frame@(EthernetFrame ethHeader ethBody)) (m@Match { inPort=inPort',..}) = +#endif +#if OPENFLOW_VERSION==1 +matches (inPort, frame@(EthernetFrame ethHeader ethBody)) (m@Match { inPort=inPort', ipTypeOfService=ipTypeOfService',..}) = +#endif + and [maybe True matchesInPort inPort', + maybe True matchesSrcEthAddress srcEthAddress, + maybe True matchesDstEthAddress dstEthAddress, + maybe True matchesVLANID vLANID, +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + maybe True matchesVLANPriority vLANPriority, +#endif + maybe True matchesEthFrameType ethFrameType, + maybe True matchesIPProtocol ipProtocol, +#if OPENFLOW_VERSION==1 + maybe True matchesIPToS ipTypeOfService', +#endif + matchesIPSourcePrefix srcIPAddress, + matchesIPDestPrefix dstIPAddress, + maybe True matchesSrcTransportPort srcTransportPort, + maybe True matchesDstTransportPort dstTransportPort ] + where + matchesInPort p = p == inPort + matchesSrcEthAddress a = IP.sourceAddress frame == a + matchesDstEthAddress a = IP.destAddress frame == a + matchesVLANID a = + case ethHeader of + EthernetHeader {} -> True + Ethernet8021Q {..}-> a == vlanId +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + matchesVLANPriority a = + case ethHeader of + EthernetHeader {} -> True + Ethernet8021Q {..} -> a == priorityCodePoint +#endif + matchesEthFrameType t = t == typeCode ethHeader + matchesIPProtocol protCode = + case ethBody of + IPInEthernet (IP.IPPacket (IP.IPHeader {..}) ipBody) -> ipProtocol == protCode + _ -> True +#if OPENFLOW_VERSION==1 + matchesIPToS tos = + case ethBody of + IPInEthernet (IP.IPPacket (IP.IPHeader {..}) _) -> tos == dscp + _ -> True +#endif + matchesIPSourcePrefix prefix = + case ethBody of + IPInEthernet ipPkt -> IP.sourceAddress ipPkt `elemOfPrefix` prefix + _ -> True + matchesIPDestPrefix prefix = + case ethBody of + IPInEthernet ipPkt -> IP.destAddress ipPkt `elemOfPrefix` prefix + _ -> True + matchesSrcTransportPort sp = + case ethBody of + IPInEthernet (IP.IPPacket ipHeader ipBody) -> + case ipBody of + IP.TCPInIP (srcPort, _) -> srcPort == sp + IP.UDPInIP (srcPort, _) -> srcPort == sp + _ -> True + _ -> True + matchesDstTransportPort dp = + case ethBody of + IPInEthernet (IP.IPPacket ipHeader ipBody) -> + case ipBody of + IP.TCPInIP (_, dstPort) -> dstPort == dp + IP.UDPInIP (_, dstPort) -> dstPort == dp + _ -> True + _ -> True diff --git a/src/Nettle/OpenFlow/Messages.hs b/src/Nettle/OpenFlow/Messages.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/OpenFlow/Messages.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} + +{-| +This module provides a logical representation of OpenFlow switches and protocol messages. +An OpenFlow message is either a switch-to-controller message or controller-to-switch message. +In either case, each message is tagged with a unique message identifier. +-} +module Nettle.OpenFlow.Messages ( + TransactionID + , SCMessage (..) + , CSMessage (..) + ) where + +import Data.Word +import qualified Nettle.OpenFlow.Port as Port +import Nettle.OpenFlow.Action +import qualified Nettle.OpenFlow.Packet as Packet +import Nettle.OpenFlow.Switch +import Nettle.OpenFlow.Match +import qualified Nettle.OpenFlow.FlowTable as FlowTable +import Nettle.OpenFlow.Statistics +import Nettle.OpenFlow.Error + +-- | Every OpenFlow message is tagged with a MessageID value. +type TransactionID = Word32 + +-- | The Switch can send the following messages to +-- the controller. +data SCMessage = SCHello -- ^ Sent after a switch establishes a TCP connection to the controller + | SCEchoRequest [Word8] -- ^ Switch requests an echo reply + | SCEchoReply [Word8] -- ^ Switch responds to an echo request + | Features SwitchFeatures -- ^ Switch reports its features + | PacketIn Packet.PacketInfo -- ^ Switch sends a packet to the controller + | PortStatus Port.PortStatus -- ^ Switch sends port status + | FlowRemoved FlowTable.FlowRemoved -- ^ Switch reports that a flow has been removed + | StatsReply StatsReply -- ^ Switch reports statistics + | Error SwitchError -- ^ Switch reports an error +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + | BarrierReply -- ^ Switch responds that a barrier has been processed +#endif + deriving (Show,Eq) + +-- |The controller can send these messages to the switch. +data CSMessage + = CSHello -- ^ Controller must send hello before sending any other messages + | CSEchoRequest [Word8] -- ^ Controller requests a switch echo + | CSEchoReply [Word8] -- ^ Controller responds to a switch echo request + | FeaturesRequest -- ^ Controller requests features information + | PacketOut Packet.PacketOut -- ^ Controller commands switch to send a packet + | FlowMod FlowTable.FlowMod -- ^ Controller modifies a switch flow table + | PortMod Port.PortMod -- ^ Controller configures a switch port + | StatsRequest StatsRequest -- ^ Controller requests statistics +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + | BarrierRequest -- ^ Controller requests a barrier +#endif + deriving (Show,Eq) + + diff --git a/src/Nettle/OpenFlow/MessagesBinary.hs b/src/Nettle/OpenFlow/MessagesBinary.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/OpenFlow/MessagesBinary.hs @@ -0,0 +1,1923 @@ +{-# LANGUAGE CPP, DisambiguateRecordFields, RecordWildCards, NamedFieldPuns #-} + +-- | This module implements parsing and unparsing functions for +-- OpenFlow messages. It exports a driver that can be used to read messages +-- from a file handle and write messages to a handle. +module Nettle.OpenFlow.MessagesBinary ( + -- * Driver and Server + messageDriver + , openFlowServer + + -- * Parsing and unparsing methods + , 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 portNum@ starts a TCP server listening for new connections at @portNum@ and +-- returns a process that can be used to receive OpenFlow events and send OpenFlow messages. +openFlowServer :: ServerPortNumber -- ^ TCP port at which the server will listen for connections. + -> IO (Process (TCPMessage (M.TransactionID, M.SCMessage)) (SockAddr, (M.TransactionID, M.CSMessage)) IOException) -- ^ A process providing a method to read @SCMessage@s from switches, a method write @CSMessage@s to switches, and terminates with an @IOException@. +openFlowServer pnum = muxedTCPServer pnum messageDriver + +-- | A message driver for use with TCP servers. +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 + +-- | Parser for @SCMessage@s +getSCMessage :: Get (M.TransactionID, M.SCMessage) +getSCMessage = do hdr <- getHeader + getSCMessageBody hdr + +{- Header -} + +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 + +-- | OpenFlow message header +data OFPHeader = + OFPHeader { msgVersion :: OpenFlowVersionID + , msgType :: MessageTypeCode + , msgLength :: Word16 + , msgTransactionID :: M.TransactionID + } deriving (Show,Eq) + +headerSize :: Int +headerSize = 8 + +-- | Unparser for OpenFlow message header +putHeader :: OFPHeader -> Put +putHeader (OFPHeader {..}) = do putWord8 msgVersion + putWord8 msgType + putWord16be msgLength + putWord32be msgTransactionID + +-- | Parser for the OpenFlow message header +getHeader :: Get OFPHeader +getHeader = do v <- getWord8 + t <- getWord8 + l <- getWord16be + x <- getWord32be + return $ OFPHeader v t l x + +-- Get SCMessage body + +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 + + +------------------------------------------- +-- SWITCH FEATURES PARSER +------------------------------------------- + +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 -- 1 << 0 +ofppsStpListen = 0 `shiftL` 8 -- 0 << 8 +ofppsStpLearn = 1 `shiftL` 8 -- 1 << 8 +ofppsStpForward = 2 `shiftL` 8 -- 2 << 8 +ofppsStpBlock = 3 `shiftL` 8 -- 3 << 8 +ofppsStpMask = 3 `shiftL` 8 -- 3 << 8 + +code2PortState :: Word32 -> (Bool, SpanningTreePortState) +code2PortState w = (w .&. ofppsLinkDown /= 0, stpState) + where stpState + | flag == ofppsStpListen = STPListening + | flag == ofppsStpLearn = STPLearning + | flag == ofppsStpForward = STPForwarding + | flag == ofppsStpBlock = STPBlocking + | otherwise = error "Unrecognized port status code." + flag = w .&. ofppsStpMask + +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 + +------------------------------------------ +-- Packet In Parser +------------------------------------------ + +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 ++ ".") + +------------------------------------------ +-- Port Status parser +------------------------------------------ +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) + + +------------------------------------------ +-- Switch Error parser +------------------------------------------ +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 + ] + + +------------------------------------------ +-- FlowRemoved parser +------------------------------------------ +#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 + + +----------------------------------------- +-- Stats Reply parser +----------------------------------------- + +getStatsReply :: Int -> Get StatsReply +getStatsReply headerLen = do + statsType <- getWord16be + flags <- getWord16be + let bodyLen = headerLen - (headerSize + 4) + let moreFlag = flags == 0x0001 + if statsType == ofpstFlow + then do flowStats <- getFlowStatsReplies bodyLen + return (FlowStatsReply moreFlag flowStats) + else if statsType == ofpstPort + then do portStats <- getPortStatsReplies bodyLen + return (PortStatsReply moreFlag portStats) + else if statsType == ofpstAggregate + then do aggStats <- getAggregateStatsReplies bodyLen + return (AggregateFlowStatsReply aggStats) + else if statsType == ofpstTable + then do tableStats <- getTableStatsReplies bodyLen + return (TableStatsReply moreFlag tableStats) + else if statsType == ofpstDesc + then do desc <- getDescriptionReply + return (DescriptionReply desc) + else +#if 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) + + +---------------------------------------------- +-- Unparsers for CSMessages +---------------------------------------------- + +-- | Unparser for @CSMessage@s +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) + + + +------------------------------------------ +-- Unparser for packet out message +------------------------------------------ + +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 + +------------------------------------------ +-- Unparser for flow mod message +------------------------------------------ +#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) + + +-- | Specification: @ofp_flow_mod_command@. +data FlowModType + = FlowAddType + | FlowModifyType + | FlowModifyStrictType + | FlowDeleteType + | FlowDeleteStrictType + deriving (Show,Eq,Ord) + +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 +-- | A set of flow mod attributes can be added to a flow modification command. +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 + + +------------------------------------------ +-- Port mod unparser +------------------------------------------ + +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 + + +---------------------------------------- +-- Stats requests unparser +---------------------------------------- + +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 + + +--------------------------------------------- +-- Parser and Unparser for Match +--------------------------------------------- + +#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 -- padding + 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 -- padding + putWord16be $ ofpm_dl_type m' + putWord8 $ ofpm_nw_proto m' + putWord8 0 -- padding + putWord8 0 -- padding + putWord8 0 -- padding + 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 -- padding + putWord16be $ ofpm_dl_type m' + putWord8 $ ofpm_nw_tos m' + putWord8 $ ofpm_nw_proto m' + putWord8 0 -- padding + putWord8 0 -- padding + 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 + + +----------------------------------- +-- Utilities +----------------------------------- +getWord8s :: Int -> Get [Word8] +getWord8s n = sequence $ replicate n getWord8 + +putWord8s :: [Word8] -> Put +putWord8s bytes = sequence_ [putWord8 b | b <- bytes] + + + diff --git a/src/Nettle/OpenFlow/Packet.hs b/src/Nettle/OpenFlow/Packet.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/OpenFlow/Packet.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE CPP, DisambiguateRecordFields, RecordWildCards #-} + +module Nettle.OpenFlow.Packet ( + -- * Sending packets + PacketOut (..) + , bufferedPacketOut + , unbufferedPacketOut + , receivedPacketOut + , BufferID + + -- * Packets not handled by a switch + , PacketInfo (..) + , PacketInReason (..) + , NumBytes + , bufferedAtSwitch + ) where + +import qualified Data.ByteString.Lazy as B +import Nettle.OpenFlow.Port +import Nettle.OpenFlow.Action +import Data.Word +import Data.Maybe (isJust) + +-- | A switch can be remotely commanded to send a packet. The packet +-- can either be a packet buffered at the switch, in which case the +-- bufferID is provided, or it can be specified explicitly by giving +-- the packet data. +data PacketOut + = PacketOut { + bufferIDData :: Either BufferID B.ByteString, -- ^either a buffer ID or the data itself + inPort :: Maybe PortID, -- ^the port at which the packet received, for the purposes of processing this command + actions :: ActionSequence -- ^actions to apply to the packet + } deriving (Eq,Show) + +-- |A switch may buffer a packet that it receives. +-- When it does so, the packet is assigned a bufferID +-- which can be used to refer to that packet. +type BufferID = Word32 + +-- | Constructs a @PacketOut@ value for a packet buffered at a switch. +bufferedPacketOut :: BufferID -> Maybe PortID -> ActionSequence -> PacketOut +bufferedPacketOut bufID inPort actions = + PacketOut { bufferIDData = Left bufID + , inPort = inPort + , actions = actions + } + +-- | Constructs a @PacketOut@ value for an unbuffered packet, including the packet data. +unbufferedPacketOut :: B.ByteString -> Maybe PortID -> ActionSequence -> PacketOut +unbufferedPacketOut pktData inPort actions = + PacketOut { bufferIDData = Right pktData + , inPort = inPort + , actions = actions + } + +-- | Constructs a @PacketOut@ value that processes the packet referred to by the @PacketInfo@ value +-- according to the specified actions. +receivedPacketOut :: PacketInfo -> ActionSequence -> PacketOut +receivedPacketOut (PacketInfo {..}) actions = + case bufferID of + Nothing -> unbufferedPacketOut packetData (Just receivedOnPort) actions + Just bufID -> bufferedPacketOut bufID (Just receivedOnPort) actions + + +-- | A switch receives packets on its ports. If the packet matches +-- some flow rules, the highest priority rule is executed. If no +-- flow rule matches, the packet is sent to the controller. When +-- packet is sent to the controller, the switch sends a message +-- containing the following information. +data PacketInfo + = PacketInfo { + bufferID :: Maybe BufferID, -- ^buffer ID if packet buffered + packetLength :: NumBytes, -- ^full length of frame + receivedOnPort :: PortID, -- ^port on which frame was received + reasonSent :: PacketInReason, -- ^reason packet is being sent + packetData :: B.ByteString -- ^ethernet frame, includes full packet only if no buffer ID + } deriving (Show,Eq,Ord) + +-- |A PacketInfo message includes the reason that the message +-- was sent, namely either there was no match, or there was +-- a match, and that match's actions included a Sent-To-Controller +-- action. +data PacketInReason = NotMatched | ExplicitSend deriving (Show,Read,Eq,Ord,Enum) + +-- | The number of bytes in a packet. +type NumBytes = Integer + +bufferedAtSwitch :: PacketInfo -> Bool +bufferedAtSwitch = isJust . bufferID diff --git a/src/Nettle/OpenFlow/Port.hs b/src/Nettle/OpenFlow/Port.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/OpenFlow/Port.hs @@ -0,0 +1,101 @@ +module Nettle.OpenFlow.Port ( + Port (..) + , PortID + , SpanningTreePortState (..) + , PortConfigAttribute (..) + , PortFeature (..) + , PortFeatures + , PortMod (..) + , PortStatus + , PortStatusUpdateReason (..) + , portAttributeOn + , portAttributeOff + ) where + +import Data.Word +import Data.Map (Map) +import qualified Data.Map as Map +import Nettle.Ethernet.EthernetAddress + +-- ^ A switch receives and sends packets on a port; The Port data type models attributes of a physical port. +data Port + = Port { + portID :: PortID, -- ^value datapath associates with a physical port + portName :: String, -- ^human-readable interface name + portAddress :: EthernetAddress, -- ^the Ethernet address of the port + portConfig :: [PortConfigAttribute], -- ^describes spanning tree and administrative settings + portLinkDown :: Bool, -- ^describes whether the link is down + portSTPState :: SpanningTreePortState, -- ^describes spanning tree state + portCurrentFeatures :: Maybe PortFeatures, -- ^port's current features + portAdvertisedFeatures :: Maybe PortFeatures, -- ^features advertised by port + portSupportedFeatures :: Maybe PortFeatures, -- ^features supported by port + portPeerFeatures :: Maybe PortFeatures -- ^features advertised by peer + } deriving (Show,Read,Eq) + +type PortID = Word16 + +data SpanningTreePortState = STPListening + | STPLearning + | STPForwarding + | STPBlocking + deriving (Show,Read,Eq,Ord,Enum) + +-- | Possible behaviors of a physical port. Specification: +-- @ofp_port_config@. +data PortConfigAttribute + = PortDown -- ^port is administratively down + | STPDisabled -- ^disable 802.1D spanning tree on this port + | OnlySTPackets -- ^drop all packets except 802.1D spanning tree packets + | NoSTPackets -- ^drop received 802.1D STP packets + | NoFlooding -- ^do not include this port when flooding + | DropForwarded -- ^drop packets forwarded to port + | NoPacketInMsg -- ^do not send packet-in messages for this port + deriving (Show,Read,Eq,Ord,Enum) + +-- | Possible port features. Specification @ofp_port_features@. +data PortFeature + = Rate10MbHD -- ^10 Mb half-duplex rate support + | Rate10MbFD -- ^10 Mb full-duplex rate support + | Rate100MbHD -- ^100 Mb half-duplex rate support + | Rate100MbFD -- ^100 Mb full-duplex rate support + | Rate1GbHD -- ^1 Gb half-duplex rate support + | Rate1GbFD -- ^1 Gb full-duplex rate support + | Rate10GbFD -- ^10 Gb full-duplex rate support + | Copper + | Fiber + | AutoNegotiation + | Pause + | AsymmetricPause + deriving (Show,Read,Eq) + +-- | Set of 'PortFeature's. Specification: bitmap of members in @enum +-- ofp_port_features@. +type PortFeatures = [PortFeature] + +-- |A port can be configured with a @PortMod@ message. +data PortMod + = PortMod { + portNumber :: PortID, -- ^ port number of port to modify + hwAddr :: EthernetAddress, -- ^ hardware address of the port + -- (redundant with the port number above; both are required) + attributesToSet :: Map PortConfigAttribute Bool -- ^ attributes mapped to true will be set on, + -- attributes mapped to false will be turned off, + -- and attributes missing will be unchanged + } deriving (Show,Read,Eq) + +-- | The @PortStatus@ represents information regarding +-- a change to a port state on a switch. +type PortStatus = (PortStatusUpdateReason, Port) + +-- | The reason that a port status update message +-- was sent. +data PortStatusUpdateReason = PortAdded + | PortDeleted + | PortModified + deriving (Show,Read,Eq,Ord,Enum) + +portAttributeOn :: PortID -> EthernetAddress -> PortConfigAttribute -> PortMod +portAttributeOn portID addr attr = PortMod portID addr (Map.singleton attr True) + +portAttributeOff :: PortID -> EthernetAddress -> PortConfigAttribute -> PortMod +portAttributeOff portID addr attr = PortMod portID addr (Map.singleton attr False) diff --git a/src/Nettle/OpenFlow/Statistics.hs b/src/Nettle/OpenFlow/Statistics.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/OpenFlow/Statistics.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE CPP #-} + +module Nettle.OpenFlow.Statistics ( + StatsRequest (..) + , TableQuery (..) +#if OPENFLOW_VERSION==1 + , PortQuery (..) + , QueueQuery (..) +#endif + , StatsReply (..) + , MoreToFollowFlag + , FlowStats (..) + , AggregateFlowStats (..) + , TableStats (..) + , PortStats (..) + , nullPortStats + , zeroPortStats + , liftIntoPortStats1 + , liftIntoPortStats2 + , Description (..) +#if OPENFLOW_VERSION==1 + , QueueStats (..) +#endif + ) where + +import Data.Word +import Nettle.OpenFlow.Port +import Nettle.OpenFlow.Match +import Nettle.OpenFlow.Action +import Nettle.OpenFlow.FlowTable +import Control.Monad (liftM,liftM2) + +data StatsRequest + = FlowStatsRequest { + statsRequestMatch :: Match, -- ^fields to match + statsRequestTableID :: TableQuery, -- ^ID of table to read + statsRequestPort :: Maybe PseudoPort -- ^if present, require matching entries to include this as an output port + } + | AggregateFlowStatsRequest { + statsRequestMatch :: Match, -- ^fields to match + statsRequestTableID :: TableQuery, -- ^ID of table to read + statsRequestPort :: Maybe PseudoPort -- ^if present, require matching entries to include this as an output port + } + | TableStatsRequest + | DescriptionRequest +#if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152 + | PortStatsRequest +#endif +#if OPENFLOW_VERSION==1 + | PortStatsRequest { + portStatsQuery :: PortQuery + } + | QueueStatsRequest { queueStatsPort :: PortQuery, queueStatsQuery:: QueueQuery } +#endif + deriving (Show,Eq) + +#if OPENFLOW_VERSION==1 +data PortQuery = AllPorts | SinglePort PortID deriving (Show,Eq,Ord) +data QueueQuery = AllQueues | SingleQueue QueueID deriving (Show,Eq,Ord) +#endif + +data TableQuery = AllTables +#if OPENFLOW_VERSION==1 + | EmergencyTable +#endif + | Table FlowTableID + deriving (Show,Eq) + + + +data StatsReply + = DescriptionReply Description + | FlowStatsReply MoreToFollowFlag [FlowStats] + | AggregateFlowStatsReply AggregateFlowStats + | TableStatsReply MoreToFollowFlag [TableStats] + | PortStatsReply MoreToFollowFlag [(PortID,PortStats)] +#if OPENFLOW_VERSION==1 + | QueueStatsReply MoreToFollowFlag [QueueStats] +#endif + deriving (Show,Eq) + +type MoreToFollowFlag = Bool + +data Description = Description { manufacturerDesc :: String + , hardwareDesc :: String + , softwareDesc :: String + , serialNumber :: String +#if OPENFLOW_VERSION==1 + , datapathDesc :: String +#endif + } deriving (Show,Eq) + +data AggregateFlowStats = + AggregateFlowStats { aggregateFlowStatsPacketCount :: Integer, + aggregateFlowStatsByteCount :: Integer, + aggregateFlowStatsFlowCount :: Integer + } deriving (Show, Eq) + + +data FlowStats = FlowStats { + flowStatsTableID :: FlowTableID, -- ^ Table ID of the flow + flowStatsMatch :: Match, -- ^ Match condition of the flow + flowStatsActions :: [Action], -- ^ Actions for the flow + flowStatsPriority :: Priority, -- ^ Priority of the flow entry (meaningful when the match is not exact). +#if OPENFLOW_VERSION==1 + flowStatsCookie :: Cookie, -- ^ Cookie associated with the flow. +#endif + flowStatsDurationSeconds :: Integer, +#if OPENFLOW_VERSION==1 + flowStatsDurationNanoseconds :: Integer, +#endif + flowStatsIdleTimeout :: Integer, + flowStatsHardTimeout :: Integer, + flowStatsPacketCount :: Integer, + flowStatsByteCount :: Integer + } + deriving (Show,Eq) + +data TableStats = + TableStats { + tableStatsTableID :: FlowTableID, + tableStatsTableName :: String, + tableStatsMaxEntries :: Integer, + tableStatsActiveCount :: Integer, + tableStatsLookupCount :: Integer, + tableStatsMatchedCount :: Integer } deriving (Show,Eq) + +data PortStats + = PortStats { + portStatsReceivedPackets :: Maybe Double, + portStatsSentPackets :: Maybe Double, + portStatsReceivedBytes :: Maybe Double, + portStatsSentBytes :: Maybe Double, + portStatsReceiverDropped :: Maybe Double, + portStatsSenderDropped :: Maybe Double, + portStatsReceiveErrors :: Maybe Double, + portStatsTransmitError :: Maybe Double, + portStatsReceivedFrameErrors :: Maybe Double, + portStatsReceiverOverrunError :: Maybe Double, + portStatsReceiverCRCError :: Maybe Double, + portStatsCollisions :: Maybe Double + } deriving (Show,Eq) + +-- | A port stats value with all fields missing. +nullPortStats :: PortStats +nullPortStats = PortStats { + portStatsReceivedPackets = Nothing, + portStatsSentPackets = Nothing, + portStatsReceivedBytes = Nothing, + portStatsSentBytes = Nothing, + portStatsReceiverDropped = Nothing, + portStatsSenderDropped = Nothing, + portStatsReceiveErrors = Nothing, + portStatsTransmitError = Nothing, + portStatsReceivedFrameErrors = Nothing, + portStatsReceiverOverrunError = Nothing, + portStatsReceiverCRCError = Nothing, + portStatsCollisions = Nothing + } + +-- | A port stats value with all fields present, but set to 0. +zeroPortStats :: PortStats +zeroPortStats = + PortStats { + portStatsReceivedPackets = Just 0, + portStatsSentPackets = Just 0, + portStatsReceivedBytes = Just 0, + portStatsSentBytes = Just 0, + portStatsReceiverDropped = Just 0, + portStatsSenderDropped = Just 0, + portStatsReceiveErrors = Just 0, + portStatsTransmitError = Just 0, + portStatsReceivedFrameErrors = Just 0, + portStatsReceiverOverrunError = Just 0, + portStatsReceiverCRCError = Just 0, + portStatsCollisions = Just 0 + } + +-- | Lift a unary function and apply to every member of a PortStats record. +liftIntoPortStats1 :: (Double -> Double) -> PortStats -> PortStats +liftIntoPortStats1 f pr1 = + PortStats { portStatsReceivedPackets = liftM f (portStatsReceivedPackets pr1), + portStatsSentPackets = liftM f (portStatsSentPackets pr1), + portStatsReceivedBytes = liftM f (portStatsReceivedBytes pr1), + portStatsSentBytes = liftM f (portStatsSentBytes pr1), + portStatsReceiverDropped = liftM f (portStatsReceiverDropped pr1), + portStatsSenderDropped = liftM f (portStatsSenderDropped pr1), + portStatsReceiveErrors = liftM f (portStatsReceiveErrors pr1), + portStatsTransmitError = liftM f (portStatsTransmitError pr1), + portStatsReceivedFrameErrors = liftM f (portStatsReceivedFrameErrors pr1), + portStatsReceiverOverrunError = liftM f (portStatsReceiverOverrunError pr1), + portStatsReceiverCRCError = liftM f (portStatsReceiverCRCError pr1), + portStatsCollisions = liftM f (portStatsCollisions pr1) + } + +-- | Lift a binary function and apply to every member of a PortStats record. +liftIntoPortStats2 :: (Double -> Double -> Double) -> PortStats -> PortStats -> PortStats +liftIntoPortStats2 f pr1 pr2 = + PortStats { portStatsReceivedPackets = liftM2 f (portStatsReceivedPackets pr1) (portStatsReceivedPackets pr2), + portStatsSentPackets = liftM2 f (portStatsSentPackets pr1) (portStatsSentPackets pr2), + portStatsReceivedBytes = liftM2 f (portStatsReceivedBytes pr1) (portStatsReceivedBytes pr2), + portStatsSentBytes = liftM2 f (portStatsSentBytes pr1) (portStatsSentBytes pr2), + portStatsReceiverDropped = liftM2 f (portStatsReceiverDropped pr1) (portStatsReceiverDropped pr2), + portStatsSenderDropped = liftM2 f (portStatsSenderDropped pr1) (portStatsSenderDropped pr2), + portStatsReceiveErrors = liftM2 f (portStatsReceiveErrors pr1) (portStatsReceiveErrors pr2), + portStatsTransmitError = liftM2 f (portStatsTransmitError pr1) (portStatsTransmitError pr2), + portStatsReceivedFrameErrors = liftM2 f (portStatsReceivedFrameErrors pr1) (portStatsReceivedFrameErrors pr2), + portStatsReceiverOverrunError = liftM2 f (portStatsReceiverOverrunError pr1) (portStatsReceiverOverrunError pr2), + portStatsReceiverCRCError = liftM2 f (portStatsReceiverCRCError pr1) (portStatsReceiverCRCError pr2), + portStatsCollisions = liftM2 f (portStatsCollisions pr1) (portStatsCollisions pr2) + } + + + + +#if OPENFLOW_VERSION==1 +data QueueStats = QueueStats { queueStatsPortID :: PortID, + queueStatsQueueID :: QueueID, + queueStatsTransmittedBytes :: Integer, + queueStatsTransmittedPackets :: Integer, + queueStatsTransmittedErrors :: Integer } deriving (Show,Eq) +#endif diff --git a/src/Nettle/OpenFlow/Switch.hs b/src/Nettle/OpenFlow/Switch.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/OpenFlow/Switch.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP #-} + +module Nettle.OpenFlow.Switch ( + SwitchFeatures (..) + , SwitchID + , SwitchCapability (..) + , maxNumberPorts + ) where + +import Data.Word +import Nettle.OpenFlow.Port +import Nettle.OpenFlow.Action + +-- |The switch features record, summarizes information about a switch +data SwitchFeatures + = SwitchFeatures { + switchID :: SwitchID, -- ^unique switch identifier + packetBufferSize :: Integer, -- ^maximum number of packets buffered at the switch + numberFlowTables :: Integer, -- ^number of flow tables + capabilities :: [SwitchCapability], -- ^switch's capabilities + supportedActions :: [ActionType], -- ^switch's supported actions + ports :: [Port] -- ^description of each port on switch + } deriving (Show,Read,Eq) + +-- |A unique identifier for a switch, also known as DataPathID. +type SwitchID = Word64 + +-- | Maximum number of ports on a switch +maxNumberPorts :: PortID +maxNumberPorts = 0xff00 + + +-- |The switch capabilities are denoted with these symbols +data SwitchCapability = HasFlowStats -- ^can provide flow statistics + | HasTableStats -- ^can provide table statistics + | HasPortStats -- ^can provide port statistics + | SpanningTree -- ^supports the 802.1d spanning tree protocol +#if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152 + | MayTransmitOverMultiplePhysicalInterfaces +#endif +#if OPENFLOW_VERSION==1 + | HasQueueStatistics -- ^can provide queue statistics + | CanMatchIPAddressesInARPPackets -- ^match IP addresses in ARP packets +#endif + | CanReassembleIPFragments -- ^can reassemble IP fragments + deriving (Show,Read,Eq,Ord,Enum) + + + diff --git a/src/Nettle/Servers/MessengerServer.hs b/src/Nettle/Servers/MessengerServer.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/Servers/MessengerServer.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE FlexibleInstances, DeriveDataTypeable #-} + +{-| This module receives messages from external network components, + such as, authentication portals, intrusion detection systems, vulnerability + scanners, etc. These components are not necessarily written in Haskell or + depend on Nettle; thus, the module acts an interface to the outside world. + + This module interacts with external components via a threaded TCP server. + Users of this module are given a channel on which they can receive messages + from external components. + + This module also assists in writing messenger clients that send messages to + the server. Note that these clients need not be written in Haskell; it would + be trivial to write a messenger client in another language. We provide a + messenger client here for your reference and for convenience of integrating + external Haskell components with Nettle. + + Messages are plain text; it is your responsibility to impose semantics for + these strings and ensure that messages from different components don't + clash. (For example, I recommend that all messages from a vulnerability + scanner be prefixed with \"Scanner\", messages from a Web portal be prefixed + with \"Portal\", etc.) + + -} + +module Nettle.Servers.MessengerServer + ( + Message + , messengerServer + , messengerClient + ) where + +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get +import qualified Data.ByteString.Lazy.Char8 as B +import Control.Concurrent +import Nettle.Servers.TwoWayChannel +import Control.Exception (finally, handle, throwIO, Exception, handle) +import Data.Typeable +import Network +import Network.Socket +import Control.Monad (forever, when, unless, liftM, replicateM) +import System.IO +import System.IO.Error (IOError, isEOFError, mkIOError, eofErrorType) + +type Message = String + +-- Marshal a message to wire format and send it on a handle. +sendMessage hdl message = + let writer = do putWord16be $ fromInteger $ toInteger $ length message + mapM_ put message + in B.hPut hdl $ runPut writer + +-- Receive a single message from a handle, or raise an IOError +receiveMessage hdl = + do isEOF <- hIsEOF hdl + when isEOF $ throwIO $ mkIOError eofErrorType "End of stream" (Just hdl) Nothing + headerBytes <- B.hGet hdl 2 + let bodyLen = fromInteger $ toInteger (decode headerBytes :: Word16) + replicateM bodyLen $ hGetChar hdl + +-- Receive messages from external components and put them onto the channel +handleMessage addr hdl chan = + do message <- receiveMessage hdl + writeChan chan (addr, message) + +trivialHandler :: IOError -> IO () +trivialHandler e = print e >> return () + +-- Handle messages from a single client component. +handleClient hdl addr chan = + handle trivialHandler $ + finally (sequence_ $ repeat $ handleMessage addr hdl chan) + (hClose hdl) + +-- Set up a client connection +acceptConnection sock chan = + do (sock', addr) <- Network.Socket.accept sock + hdl <- socketToHandle sock' ReadWriteMode + hSetBuffering hdl NoBuffering + forkIO $ handleClient hdl addr chan + +-- | Run a server that listens for connections from external messenger +-- components. The server is run in a separate thread; the current thread +-- returns a channel to the user where he can receive messages from the external +-- components. Messages are annotated with the client's address information. +messengerServer :: PortID -> IO (Chan (SockAddr, Message)) +messengerServer port = + do sock <- listenOn port + chan <- newChan + forkIO $ finally (forever $ acceptConnection sock chan) (sClose sock) + return chan + +data DeadException = DeadException + deriving (Typeable, Show) +instance Exception DeadException + +-- | Connect to a messenger server (i.e., a Nettle controller that runs +-- messengerServer) and send messages. Note that although this function +-- returns a bidirectional channel for both sending and receiving messages +-- from the server, the server currently does not send any messages. +messengerClient :: HostName -> PortID -> (Chan2 (Maybe Message) (Maybe Message) () -> IO ()) -> IO () +messengerClient host port client = + do + hdl <- connectTo host port + chan <- newChan2 + forkIO $ client chan >> kill chan () + forkIO $ whenDead chan >> writeChan2 chan Nothing + handleMessage hdl $ theOtherEnd2 chan + hClose hdl + where handleMessage hdl ch = do message <- readChan2 ch + case message of + Just msg -> do sendMessage hdl msg + handleMessage hdl ch + Nothing -> return () diff --git a/src/Nettle/Servers/MultiplexedTCPServer.hs b/src/Nettle/Servers/MultiplexedTCPServer.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/Servers/MultiplexedTCPServer.hs @@ -0,0 +1,64 @@ +-- | This module provides a TCP server that multiplexes incoming and outgoing messages +-- from many connected peers onto a single pair of input and output channels. The socket address +-- of the peer is used to identify the source and destination of messages. +-- +-- This interface introduces a new error condition: that a message on the outgoing channel has a +-- socket address for which no socket exists. This may occur because of incorrect usage of this library, +-- or because a peer disconnected after the client placed a message on the outgoing channel, +-- but before that message was sent. Currently, the server does not notify its caller of the occurrence of this error. +module Nettle.Servers.MultiplexedTCPServer + ( + muxedTCPServer, + MultiplexedProcess, + TCPMessage(..) + ) where + +import Prelude hiding (interact, catch) +import Nettle.Servers.TwoWayChannel +import Nettle.Servers.TCPServer +import Control.Concurrent +import Control.Exception +import Control.Monad +import qualified Data.Map as Map +import Data.Binary + +-- | A multiplexed process has inputs and outputs that are tagged with the @SockAddr@ of the +-- sending or receiving peer, and carries connection start and connection end events. +type MultiplexedProcess a b = Process (TCPMessage a) (SockAddr, b) IOException + +-- | The type of externally visible events that may occur for the multiplexed TCP server. +data TCPMessage a = ConnectionEstablished SockAddr -- ^ A connection to a peer with the given address is established. + | ConnectionTerminated SockAddr IOException -- ^ A connection with the given address is terminated, due to the given exception. + | PeerMessage SockAddr a -- ^ A message of type @a@ has been received from the peer with the given address. + deriving (Show,Eq) + +-- | Runs a TCP server returning a process that outputs messages of type @a@ from connected peers, tagged with +-- their @SockAddr@, and accepts messages of type @b@ for peers, again tagged with their @SockAddr@. +muxedTCPServer :: Show a => ServerPortNumber -> TCPMessageDriver a b -> IO (MultiplexedProcess a b) +muxedTCPServer pstring driver = do + resultCh <- newChan2 + peers <- tcpServer pstring driver + addrToChanMapVar <- newMVar Map.empty + forkIO $ sequence_ [ forkIO (multiplex addrToChanMapVar resultCh addr process) | (addr,process) <- peers ] + forkIO $ demultiplex addrToChanMapVar resultCh + let ch' = theOtherEnd2 resultCh + d <- newEmptyMVar + return (Process { readP = readChan2 ch', + tellP = writeChan2 ch', + whenDeadP = readMVar d }) + + where + multiplex addrToChanMapVar resultCh addr process = + do modifyMVar_ addrToChanMapVar (return . Map.insert addr process) + writeChan2 resultCh (ConnectionEstablished addr) + catch (forever (readP process >>= writeChan2 resultCh . PeerMessage addr)) + (\e -> modifyMVar_ addrToChanMapVar (return . Map.delete addr) >> + writeChan2 resultCh (ConnectionTerminated addr e)) + + demultiplex addrToChanMapVar resultCh = + forever (readChan2 resultCh >>= \(addr, msg) -> withMVar addrToChanMapVar (lookupAndSend addr msg)) + where lookupAndSend addr msg addrToChanMap = + case Map.lookup addr addrToChanMap of + Nothing -> return () -- The message could not be sent because the peer has disconnected. + Just process -> tellP process msg + diff --git a/src/Nettle/Servers/TCPServer.hs b/src/Nettle/Servers/TCPServer.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/Servers/TCPServer.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE StandaloneDeriving, ScopedTypeVariables #-} + +-- | Provides a generic TCP server, parameterized over the +-- server's listening port and the types of messages received from +-- and sent to clients. +module Nettle.Servers.TCPServer ( + tcpServer, + ServerPortNumber, + TCPMessageDriver (..), + Peer , + Process (..), + readAll, + writeAll, + SockAddr + + ) where + +import Prelude hiding (catch) +import Control.Monad +import Control.Concurrent +import Control.Exception +import Network.Socket +import System.IO +import Data.Word + +type ServerPortNumber = Word16 + +-- | A Peer is a TCP peer. It consists of a @SockAddr@ value giving the +-- the socket address of the peer, as well as a @Process@ value which provides methods to access +-- messages received from the peer and send messages to a peer. +type Peer a b = (SockAddr, Process a b IOException) + +deriving instance Ord SockAddr + +{- +data SockAddr + = SockAddrInet PortNumber HostAddress + | SockAddrInet6 PortNumber FlowInfo HostAddress6 ScopeID + | SockAddrUnix String + +newtype PortNumber = PortNum Word16 deriving ( Eq, Ord ) +type HostAddress = Word32 +-} + +-- | A @Process a b c@ represents a process with an API that +-- allows another IO computation to observe its outputs (of type @a@), to +-- supply it with inputs (of type @b@), and to observe when it terminates. +data Process a b c = Process { readP :: IO a, -- ^ interact with the process by receiving one of its outputs; should block until the process emits a value. + tellP :: b -> IO (), -- ^ interact with the process by sending it an input; should be non-blocking. + whenDeadP :: IO c -- ^ should block until the process terminates, carrying an output value of type @c@. + } + +-- | Read all of the output from the process as a lazy stream. +readAll :: Process a b c -> IO [a] +readAll p = do ch <- newChan + forkIO $ forever (readP p >>= writeChan ch) + as <- getChanContents ch + return as + +-- | Write a list to the process; does not return until every element of the list has been sent to the process. +writeAll :: Process a b c -> [b] -> IO () +writeAll p bs = sequence_ [tellP p b | b <- bs] + +-- | A @TCPMessageDriver a b@ is used by the @tcpServer@ to read messages of type @a@ from the underlying TCP sockets with +-- peers as well as write messages of type @b@ to the TCP sockets. +data TCPMessageDriver a b = + TCPMessageDriver { getMessage :: Handle -> IO (Maybe a) -- ^ Method to read a value from the handle. Returns @Nothing@ if the read failed. + , putMessage :: b -> Handle -> IO () -- ^ Method to write a value to a handle. + } + + +-- | tcpServer starts a TCP server at the given port number, waiting for new connections. +-- Whenever a new connection is established, new threads are created for reading and writing +-- to the thread, using the given tcp message driver. The socket address of the other side of +-- the connection, along with a pair of channels for the incoming messages and outgoing messages +-- is placed on the result channel. This method returns immediately. +tcpServer :: (Show a) => ServerPortNumber -> TCPMessageDriver a b -> IO ([Peer a b]) +tcpServer pstring driver = do + addrinfos <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]})) Nothing (Just $ show pstring) + let serveraddr = head addrinfos + sock <- socket (addrFamily serveraddr) Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bindSocket sock (addrAddress serveraddr) + listen sock queueLength + resultChan <- newChan + forkIO $ finally (procRequests sock resultChan) (sClose sock) + getChanContents resultChan + + where + queueLength = maxListenQueue + + procRequests masterSock resultChan = forever acceptConnection + where acceptConnection = do + (connsock, clientaddr) <- accept masterSock + connhdl <- socketToHandle connsock ReadWriteMode + hSetBuffering connhdl (BlockBuffering Nothing) + deadVar <- newEmptyMVar + let readMessage = do msg <- getMessage driver connhdl + case msg of + Nothing -> fail "read returned nothing" + Just msg' -> return msg' + writeMessage outMsg = do putMessage driver outMsg connhdl + hFlush connhdl + + peerProcess = Process { readP = readMessage , + tellP = writeMessage, + whenDeadP = readMVar deadVar } + + writeChan resultChan (clientaddr, peerProcess) + + + + diff --git a/src/Nettle/Servers/TwoWayChannel.hs b/src/Nettle/Servers/TwoWayChannel.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/Servers/TwoWayChannel.hs @@ -0,0 +1,56 @@ +module Nettle.Servers.TwoWayChannel ( + Chan2, + whenDead, + kill, + newChan2, + readChan2, + writeChan2, + getChanContents2, + writeList2Chan2, + theOtherEnd2 + ) where + +import Control.Concurrent + +data Chan2 a b c = Chan2 {inCh::Chan a, outCh::Chan b, deadVar :: MVar c} + + +whenDead :: Chan2 a b c -> IO c +whenDead mch2 = readMVar (deadVar mch2) + +kill :: Chan2 a b c -> c -> IO () +kill mch c = putMVar (deadVar mch) c + + +newChan2 :: IO (Chan2 a b c) +newChan2 = do + i <- newChan + o <- newChan + d <- newEmptyMVar + return $ Chan2 {inCh=i, outCh=o, deadVar=d} + +readChan2 :: Chan2 a b c -> IO a +readChan2 (Chan2 inC outC _) = readChan inC + +writeChan2 :: Chan2 a b c -> b -> IO () +writeChan2 (Chan2 inC outC _) = writeChan outC + +getChanContents2 :: Chan2 a b c -> IO [a] +getChanContents2 (Chan2 inC _ _) = getChanContents inC + +writeList2Chan2 :: Chan2 a b c -> [b] -> IO () +writeList2Chan2 (Chan2 _ outCh _) bs = writeList2Chan outCh bs + +isEmptyChan2 :: Chan2 a b c -> IO Bool +isEmptyChan2 (Chan2 inCh _ _) = isEmptyChan inCh + +theOtherEnd2 :: Chan2 a b c -> Chan2 b a c +theOtherEnd2 (Chan2 inC outC d) = Chan2 outC inC d + + +connect2 :: Chan2 a b c -> Chan2 b a c -> IO () +connect2 (Chan2 inC outC _) (Chan2 inC' outC' _) = do + forkIO $ (readChan inC >>= writeChan outC') + forkIO $ (readChan inC' >>= writeChan outC) + return () +