nettle-openflow (empty) → 0.1

raw patch · 23 files changed

+4174/−0 lines, 23 filesdep +basedep +bimapdep +binarysetup-changed

Dependencies added: base, bimap, binary, bytestring, containers, mtl, network, parsec

Files

• LICENSE +29/−0
• Setup.hs +4/−0
• nettle-openflow.cabal +56/−0
• src/Examples/SimpleImperativeIONetworkControl/NetLearningSwitch.hs +134/−0
• src/Examples/SimpleImperativeIONetworkControl/SimpleImperativeIONetworkControl.hs +31/−0
• src/Nettle/Ethernet/EthernetAddress.hs +41/−0
• src/Nettle/Ethernet/EthernetFrame.hs +186/−0
• src/Nettle/IPv4/IPAddress.hs +112/−0
• src/Nettle/IPv4/IPPacket.hs +182/−0
• src/Nettle/OpenFlow/Action.hs +171/−0
• src/Nettle/OpenFlow/Error.hs +81/−0
• src/Nettle/OpenFlow/FlowTable.hs +145/−0
• src/Nettle/OpenFlow/Match.hs +211/−0
• src/Nettle/OpenFlow/Messages.hs +58/−0
• src/Nettle/OpenFlow/MessagesBinary.hs +1923/−0
• src/Nettle/OpenFlow/Packet.hs +89/−0
• src/Nettle/OpenFlow/Port.hs +101/−0
• src/Nettle/OpenFlow/Statistics.hs +222/−0
• src/Nettle/OpenFlow/Switch.hs +49/−0
• src/Nettle/Servers/MessengerServer.hs +116/−0
• src/Nettle/Servers/MultiplexedTCPServer.hs +64/−0
• src/Nettle/Servers/TCPServer.hs +113/−0
• src/Nettle/Servers/TwoWayChannel.hs +56/−0

@@ -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 <ORGANIZATION> 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.

@@ -0,0 +1,4 @@+import Distribution.Simple++main = defaultMain+

@@ -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 (<http://www.openflowswitch.org>) 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 

@@ -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)+++++

@@ -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))+

@@ -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)+

@@ -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+

@@ -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)

@@ -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)+

@@ -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+++

@@ -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)+

@@ -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)

@@ -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

@@ -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)++

@@ -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]+++

@@ -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

@@ -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)

@@ -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                                                                                 

@@ -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)+++       

@@ -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 ()

@@ -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 +

@@ -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) +  +  ++

@@ -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 ()+