nettle-openflow 0.1 → 0.2.0
raw patch · 30 files changed
+3713/−2822 lines, 30 filesdep +HListdep +arraydep +binary-strictdep ~basedep ~networkdep ~parsec
Dependencies added: HList, array, binary-strict, syb
Dependency ranges changed: base, network, parsec
Files
- nettle-openflow.cabal +34/−23
- src/Examples/Flood.hs +35/−0
- src/Examples/Hub.hs +60/−0
- src/Examples/SimpleImperativeIONetworkControl/NetLearningSwitch.hs +0/−134
- src/Examples/SimpleImperativeIONetworkControl/SimpleImperativeIONetworkControl.hs +0/−31
- src/Nettle/Ethernet/AddressResolutionProtocol.hs +144/−0
- src/Nettle/Ethernet/EthernetAddress.hs +94/−16
- src/Nettle/Ethernet/EthernetFrame.hs +178/−101
- src/Nettle/IPv4/IPAddress.hs +19/−14
- src/Nettle/IPv4/IPPacket.hs +121/−41
- src/Nettle/OpenFlow.hs +33/−0
- src/Nettle/OpenFlow/Action.hs +0/−17
- src/Nettle/OpenFlow/FlowTable.hs +9/−55
- src/Nettle/OpenFlow/Match.hs +102/−111
- src/Nettle/OpenFlow/Messages.hs +18/−18
- src/Nettle/OpenFlow/MessagesBinary.hs +1878/−1909
- src/Nettle/OpenFlow/Packet.hs +24/−20
- src/Nettle/OpenFlow/Port.hs +3/−3
- src/Nettle/OpenFlow/StrictPut.hs +138/−0
- src/Nettle/OpenFlow/Switch.hs +21/−5
- src/Nettle/Servers/Client.hs +79/−0
- src/Nettle/Servers/MessengerServer.hs +0/−116
- src/Nettle/Servers/MultiplexedTCPServer.hs +44/−39
- src/Nettle/Servers/Server.hs +249/−0
- src/Nettle/Servers/TCPServer.hs +0/−113
- src/Nettle/Servers/TwoWayChannel.hs +0/−56
- src/Nettle/Topology/ExtendedDouble.hs +20/−0
- src/Nettle/Topology/FloydWarshall.hs +105/−0
- src/Nettle/Topology/LabelledGraph.hs +154/−0
- src/Nettle/Topology/Topology.hs +151/−0
nettle-openflow.cabal view
@@ -1,56 +1,67 @@ Name: nettle-openflow-Version: 0.1-Synopsis: High level configuration and control of computer networks.+Version: 0.2.0+Synopsis: OpenFlow protocol messages, binary formats, and servers. 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+Author: Andreas Voellmy, Ashish Agarwal, 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.-+Description: + This package provides data types that model the messages of the OpenFlow protocol, + functions that implement serialization and deserialization between these data+ types and their binary representations in the protocol, and an efficient OpenFlow server.+ The library is under active development. -extra-source-files: src/Examples/SimpleImperativeIONetworkControl/NetLearningSwitch.hs - src/Examples/SimpleImperativeIONetworkControl/SimpleImperativeIONetworkControl.hs+extra-source-files:+ src/Examples/Hub.hs+ src/Examples/Flood.hs Library- hs-source-dirs: src+ hs-source-dirs: src+ ghc-options: -O2 -funbox-strict-fields cpp-options: "-DOPENFLOW_VERSION=1" exposed-modules: Nettle.Ethernet.EthernetAddress Nettle.Ethernet.EthernetFrame+ Nettle.Ethernet.AddressResolutionProtocol 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.Packet+ Nettle.OpenFlow.Messages+ Nettle.OpenFlow.StrictPut Nettle.OpenFlow.MessagesBinary+ Nettle.OpenFlow+ Nettle.Servers.Server+ Nettle.Servers.Client+ Nettle.Servers.MultiplexedTCPServer+ Nettle.Topology.ExtendedDouble+ Nettle.Topology.LabelledGraph+ Nettle.Topology.FloydWarshall+ Nettle.Topology.Topology build-depends:- base >= 4 && < 5+ base >= 4.4.0.0 && < 5 , bytestring , binary + , binary-strict , mtl- , parsec- , network+ , parsec >= 3.1+ , network >= 2.3 , containers , bimap + , HList+ , syb + , array++
+ src/Examples/Flood.hs view
@@ -0,0 +1,35 @@+import Nettle.Servers.Server+import Nettle.OpenFlow+import Control.Concurrent+import System.Environment++main :: IO ()+main =+ do portNum <- getPortNumber+ ofpServer <- startOpenFlowServer Nothing portNum+ forever (do (switch, features) <- acceptSwitch ofpServer+ forkIO (handleSwitch switch)+ )+ closeServer ofpServer+ + +getPortNumber :: IO ServerPortNumber +getPortNumber + = do args <- getArgs+ if length args < 1 + then error "Requires one command-line argument specifying the server port number."+ else return (read (args !! 0))+++handleSwitch :: SwitchHandle -> IO ()+handleSwitch switch + = do untilNothing (receiveFromSwitch switch) (messageHandler switch)+ closeSwitchHandle switch+++messageHandler :: SwitchHandle -> (TransactionID, SCMessage) -> IO ()+messageHandler switch (xid, scmsg) =+ case scmsg of+ PacketIn pktIn -> sendToSwitch switch (xid, PacketOut (receivedPacketOut pktIn flood))+ _ -> return ()+
+ src/Examples/Hub.hs view
@@ -0,0 +1,60 @@+{-+A simple controller that responds to each packet-in message by +installing a flow rule to process the packet-in packet and similar packets+using the switch's Flood port. The rule is installed with a 5 second hard (and inactivity)+timeout so the rule should be removed by the switch after 5 seconds.++This controller uses the Nettle.Servers.Server module and forks a Haskell thread +for every connecting OpenFlow switch. +-}++import Nettle.Servers.Server+import Nettle.OpenFlow+import Control.Concurrent+import qualified Data.ByteString as B+import System.Environment++main :: IO ()+main =+ do portNum <- getPortNumber+ ofpServer <- startOpenFlowServer Nothing portNum+ forever (do (switch,sfr) <- acceptSwitch ofpServer+ forkIO (handleSwitch switch)+ )+ closeServer ofpServer+ + +getPortNumber :: IO ServerPortNumber +getPortNumber + = do args <- getArgs+ if length args < 1 + then error "Requires one command-line argument specifying the server port number."+ else return (read (args !! 0))+++handleSwitch :: SwitchHandle -> IO ()+handleSwitch switch + = do untilNothing (receiveFromSwitch switch) (messageHandler switch)+ closeSwitchHandle switch+++messageHandler :: SwitchHandle -> (TransactionID, SCMessage) -> IO ()+messageHandler switch (xid, scmsg) =+ case scmsg of+ PacketIn pkt -> + case enclosedFrame pkt of + Left s -> putStrLn (s ++ ": " ++ show (B.unpack (packetData pkt)))+ Right frame -> + let flowEntry = AddFlow { match = frameToExactMatch (receivedOnPort pkt) frame+ , priority = 32768+ , actions = [SendOutPort Flood]+ , cookie = 0+ , idleTimeOut = ExpireAfter 5+ , hardTimeOut = ExpireAfter 5+ , notifyWhenRemoved = False+ , applyToPacket = bufferID pkt+ , overlapAllowed = False+ } + in sendToSwitch switch (xid, FlowMod flowEntry)+ _ -> return ()+
− src/Examples/SimpleImperativeIONetworkControl/NetLearningSwitch.hs
@@ -1,134 +0,0 @@-{-# 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)-----
− src/Examples/SimpleImperativeIONetworkControl/SimpleImperativeIONetworkControl.hs
@@ -1,31 +0,0 @@-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))-
+ src/Nettle/Ethernet/AddressResolutionProtocol.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE MultiParamTypeClasses, RecordWildCards, TypeOperators #-}++module Nettle.Ethernet.AddressResolutionProtocol ( + ARPPacket (..)+ , ARPQueryPacket(..)+ , ARPReplyPacket(..)+ , getARPPacket+ , getARPPacket2+ , putARPPacket+ ) where++import Nettle.Ethernet.EthernetAddress+import Nettle.IPv4.IPAddress+import Data.Binary+import Data.Binary.Put+import Data.Word+import Control.Monad+import Control.Monad.Error+import Data.HList+import qualified Data.Binary.Strict.Get as Strict+import qualified Nettle.OpenFlow.StrictPut as Strict+import qualified Data.Binary.Get as Binary++data ARPPacket = ARPQuery ARPQueryPacket+ | ARPReply ARPReplyPacket+ deriving (Show, Eq)++data ARPQueryPacket = + ARPQueryPacket { querySenderEthernetAddress :: EthernetAddress+ , querySenderIPAddress :: IPAddress+ , queryTargetIPAddress :: IPAddress+ } deriving (Show,Eq)+++data ARPReplyPacket = + ARPReplyPacket { replySenderEthernetAddress :: EthernetAddress+ , replySenderIPAddress :: IPAddress+ , replyTargetEthernetAddress :: EthernetAddress+ , replyTargetIPAddress :: IPAddress+ } + deriving (Show, Eq)++queryOpCode, replyOpCode :: Word16+queryOpCode = 1+replyOpCode = 2+++-- | Parser for ARP packets+getARPPacket :: Strict.Get (Maybe ARPPacket)+getARPPacket = do + htype <- Strict.getWord16be+ ptype <- Strict.getWord16be+ hlen <- Strict.getWord8+ plen <- Strict.getWord8+ opCode <- Strict.getWord16be+ sha <- getEthernetAddress+ spa <- getIPAddress+ tha <- getEthernetAddress+ tpa <- getIPAddress+ body <- if opCode == queryOpCode+ then return ( Just (ARPQuery (ARPQueryPacket { querySenderEthernetAddress = sha+ , querySenderIPAddress = spa+ , queryTargetIPAddress = tpa+ } + )+ )+ )+ else if opCode == replyOpCode + then return (Just (ARPReply (ARPReplyPacket { replySenderEthernetAddress = sha+ , replySenderIPAddress = spa+ , replyTargetEthernetAddress = tha+ , replyTargetIPAddress = tpa+ } + )+ )+ )+ else return Nothing+ return body++-- | Parser for ARP packets+getARPPacket2 :: Binary.Get (Maybe ARPPacket)+getARPPacket2 = do + htype <- Binary.getWord16be+ ptype <- Binary.getWord16be+ hlen <- Binary.getWord8+ plen <- Binary.getWord8+ opCode <- Binary.getWord16be+ sha <- getEthernetAddress2+ spa <- getIPAddress2+ tha <- getEthernetAddress2+ tpa <- getIPAddress2+ body <- if opCode == queryOpCode+ then return ( Just (ARPQuery (ARPQueryPacket { querySenderEthernetAddress = sha+ , querySenderIPAddress = spa+ , queryTargetIPAddress = tpa+ } + )+ )+ )+ else if opCode == replyOpCode + then return (Just (ARPReply (ARPReplyPacket { replySenderEthernetAddress = sha+ , replySenderIPAddress = spa+ , replyTargetEthernetAddress = tha+ , replyTargetIPAddress = tpa+ } + )+ )+ )+ else return Nothing+ return body+++putARPPacket :: ARPPacket -> Strict.Put+putARPPacket body = + case body of + (ARPQuery (ARPQueryPacket {..})) -> + do + Strict.putWord16be ethernetHardwareType+ Strict.putWord16be ipProtocolType+ Strict.putWord8 numberOctetsInEthernetAddress+ Strict.putWord8 numberOctetsInIPAddress+ Strict.putWord16be queryOpCode+ putEthernetAddress querySenderEthernetAddress+ putIPAddress querySenderIPAddress+ putEthernetAddress (ethernetAddress 0 0 0 0 0 0)+ putIPAddress queryTargetIPAddress+ + (ARPReply (ARPReplyPacket {..})) -> + do + Strict.putWord16be ethernetHardwareType+ Strict.putWord16be ipProtocolType+ Strict.putWord8 numberOctetsInEthernetAddress+ Strict.putWord8 numberOctetsInIPAddress+ Strict.putWord16be replyOpCode+ putEthernetAddress replySenderEthernetAddress+ putIPAddress replySenderIPAddress+ putEthernetAddress replyTargetEthernetAddress+ putIPAddress replyTargetIPAddress++ethernetHardwareType = 1+ipProtocolType = 0x0800+numberOctetsInEthernetAddress = 6+numberOctetsInIPAddress = 4+
src/Nettle/Ethernet/EthernetAddress.hs view
@@ -1,41 +1,119 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-} module Nettle.Ethernet.EthernetAddress ( -- * Ethernet address- EthernetAddress(..)+ EthernetAddress+ , ethernetAddress+ , ethernetAddress64+ , unpack+ , unpack64+ , pack_32_16 , isReserved+ , broadcastAddress -- * Parsers and unparsers , getEthernetAddress+ , getEthernetAddress2 , putEthernetAddress+ , putEthernetAddress2 ) where import Data.Word import Data.Bits import Data.Binary+import Data.Binary.Put as P+import qualified Data.Binary.Strict.Get as Strict+import qualified Nettle.OpenFlow.StrictPut as Strict+import Data.Generics+import qualified Data.Binary.Get as Binary+import GHC.Base+import GHC.Word --- | An Ethernet address consists of 6 bytes.-data EthernetAddress = EthernetAddress Word8 Word8 Word8 Word8 Word8 Word8- deriving (Show,Read,Eq,Ord)++-- | An Ethernet address consists of 6 bytes. It is stored in a single 64-bit value.+newtype EthernetAddress = EthernetAddress Word64 + deriving (Show,Read,Eq,Ord, Data, Typeable) +-- | Builds an ethernet address from a Word64 value. +-- The two most significant bytes are irrelevant; only the bottom 6 bytes are used.+ethernetAddress64 :: Word64 -> EthernetAddress+ethernetAddress64 w64 = EthernetAddress (w64 `mod` 0x01000000000000)+{-# INLINE ethernetAddress64 #-}++ethernetAddress :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> EthernetAddress +ethernetAddress w1 w2 w3 w4 w5 w6 + = let w64 = (shiftL (fromIntegral w1) 40) .|.+ (shiftL (fromIntegral w2) 32) .|.+ (shiftL (fromIntegral w3) 24) .|. + (shiftL (fromIntegral w4) 16) .|. + (shiftL (fromIntegral w5) 8) .|. + (fromIntegral w6)+ in EthernetAddress w64+ +pack_32_16 :: Word32 -> Word16 -> Word64+pack_32_16 w32 w16 + = (fromIntegral w32 `shiftL` 16) .|. fromIntegral w16+{-# INLINE pack_32_16 #-}++-- (W32# w32) (W16# w16) +-- = W64# ((w32 `uncheckedShiftL#` 16#) `or#` w16)++unpack :: EthernetAddress -> (Word8,Word8,Word8,Word8,Word8,Word8)+unpack (EthernetAddress w64) = + let a1 = fromIntegral (shiftR w64 40)+ a2 = fromIntegral (shiftR w64 32 `mod` 0x0100)+ a3 = fromIntegral (shiftR w64 24 `mod` 0x0100)+ a4 = fromIntegral (shiftR w64 16 `mod` 0x0100)+ a5 = fromIntegral (shiftR w64 8 `mod` 0x0100)+ a6 = fromIntegral (w64 `mod` 0x0100)+ in (a1,a2,a3,a4,a5,a6)+{-# INLINE unpack #-}++unpack64 :: EthernetAddress -> Word64+unpack64 (EthernetAddress e) = e+{-# INLINE unpack64 #-}+ -- | Parse an Ethernet address from a ByteString-getEthernetAddress :: Get EthernetAddress +getEthernetAddress :: Strict.Get EthernetAddress getEthernetAddress = - do a1 <- get- a2 <- get- a3 <- get- a4 <- get- a5 <- get- a6 <- get- return $ EthernetAddress a1 a2 a3 a4 a5 a6- + do w32 <- Strict.getWord32be + w16 <- Strict.getWord16be+ return (EthernetAddress (pack_32_16 w32 w16))+{-# INLINE getEthernetAddress #-} ++getEthernetAddress2 :: Binary.Get EthernetAddress +getEthernetAddress2 = + do w32 <- Binary.getWord32be + w16 <- Binary.getWord16be+ return (EthernetAddress (pack_32_16 w32 w16))++ -- | 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+putEthernetAddress :: EthernetAddress -> Strict.Put +putEthernetAddress (EthernetAddress w64) + = Strict.putWord32be (fromIntegral (shiftR w64 16)) >>+ Strict.putWord16be (fromIntegral (w64 `mod` 0x010000))+{-# INLINE putEthernetAddress #-} ++-- | Unparse an Ethernet address to a ByteString +putEthernetAddress2 :: EthernetAddress -> P.Put +putEthernetAddress2 (EthernetAddress w64) -- a1 a2 a3 a4 a5 a6) = + = P.putWord32be (fromIntegral (shiftR w64 16)) >>+ P.putWord16be (fromIntegral (w64 `mod` 0x010000))+{-# INLINE putEthernetAddress2 #-} ++ isReserved :: EthernetAddress -> Bool-isReserved (EthernetAddress a1 a2 a3 a4 a5 a6) = +isReserved e = + let (a1, a2, a3, a4, a5, a6) = unpack e+ in a1 == 0x01 && a2 == 0x80 && a3 == 0xc2 && a4 == 0 && ((a5 .&. 0xf0) == 0) +broadcastAddress :: EthernetAddress+broadcastAddress = EthernetAddress 0xffffffffffff
src/Nettle/Ethernet/EthernetFrame.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FunctionalDependencies #-}+{-# LANGUAGE BangPatterns #-} -- | This module provides data structures for Ethernet frames -- as well as parsers and unparsers for Ethernet frames. @@ -6,6 +7,7 @@ -- * Data types EthernetFrame(..)+ , EthernetBody(..) , EthernetHeader(..) , EthernetTypeCode , ethTypeVLAN@@ -15,49 +17,97 @@ , typeEth2Cutoff , VLANPriority , VLANID- , EthernetBody(..)- , ARPPacket(..)- , ARPOpCode(..)+ , eth_ip_packet+ , eth_ip_tcp_packet+ , eth_ip_udp_packet+ , foldEthernetFrame+ , foldEthernetBody -- * Parsers and unparsers - , GetE- , ErrorMessage- , runGetE- , getEthernetFrame + , getEthernetFrame , getEthHeader+ , getEthernetFrame2+ , getEthHeader2 , putEthHeader- , getARPPacket + , putEthFrame+ + -- * ARP frames + , arpQuery+ , arpReply+ ) where import Nettle.Ethernet.EthernetAddress import Nettle.IPv4.IPPacket import Nettle.IPv4.IPAddress-import qualified Data.ByteString.Lazy as B+import Nettle.Ethernet.AddressResolutionProtocol+import qualified Data.ByteString 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+import Data.HList+import qualified Data.Binary.Strict.Get as Strict+import qualified Nettle.OpenFlow.StrictPut as Strict+import qualified Data.Binary.Get as Binary --- It was based on http://en.wikipedia.org/wiki/File:Ethernet_Type_II_Frame_format.svg+-- | An Ethernet frame is either an IP packet, an ARP packet, or an uninterpreted @ByteString@.+-- Based on http://en.wikipedia.org/wiki/File:Ethernet_Type_II_Frame_format.svg+type EthernetFrame = EthernetHeader :*: EthernetBody :*: HNil+ --- | An Ethernet frame consists of an Ethernet header and an Ethernet body.-data EthernetFrame = EthernetFrame EthernetHeader EthernetBody - deriving (Show,Eq)+data EthernetBody = IPInEthernet !IPPacket+ | ARPInEthernet !ARPPacket+ | UninterpretedEthernetBody !B.ByteString+ 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 }+foldEthernetFrame :: (EthernetHeader -> EthernetBody -> a) -> EthernetFrame -> a+foldEthernetFrame f (HCons h (HCons b HNil)) = f h b++foldEthernetBody :: (IPPacket -> a) -> (ARPPacket -> a) -> (B.ByteString -> a) -> EthernetBody -> a+foldEthernetBody f g h (IPInEthernet x) = f x+foldEthernetBody f g h (ARPInEthernet x) = g x+foldEthernetBody f g h (UninterpretedEthernetBody x) = h x++withFrame :: HList l + => (EthernetBody -> Maybe l) + -> EthernetFrame + -> Maybe (EthernetHeader :*: l)+withFrame f frame = foldEthernetFrame (\h b -> fmap (hCons h) (f b)) frame++fromIPPacket :: EthernetBody -> Maybe IPPacket+fromIPPacket = foldEthernetBody Just (const Nothing) (const Nothing)++fromARPPacket :: EthernetBody -> Maybe (ARPPacket :*: HNil)+fromARPPacket = foldEthernetBody (const Nothing) (\x -> Just (hCons x HNil)) (const Nothing)++eth_ip_packet :: EthernetFrame -> Maybe (EthernetHeader :*: IPPacket)+eth_ip_packet = withFrame fromIPPacket++eth_ip_tcp_packet :: EthernetFrame -> Maybe (EthernetHeader :*: IPHeader :*: TCPHeader :*: HNil)+eth_ip_tcp_packet = withFrame $ fromIPPacket >=> withIPPacket fromTCPPacket++eth_ip_udp_packet :: EthernetFrame -> Maybe (EthernetHeader :*: IPHeader :*: UDPHeader :*: B.ByteString :*: HNil)+eth_ip_udp_packet = withFrame $ fromIPPacket >=> withIPPacket fromUDPPacket++eth_arp_packet :: EthernetFrame -> Maybe (EthernetHeader :*: ARPPacket :*: HNil)+eth_arp_packet = withFrame fromARPPacket+++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.@@ -65,87 +115,141 @@ 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+arpQuery :: EthernetAddress -- ^ source hardware address+ -> IPAddress -- ^ source IP address+ -> IPAddress -- ^ target IP address+ -> EthernetFrame+arpQuery sha spa tpa = hCons hdr (hCons (ARPInEthernet ( body)) hNil)+ where hdr = EthernetHeader { destMACAddress = broadcastAddress+ , sourceMACAddress = sha+ , typeCode = ethTypeARP + } + body = ARPQuery (ARPQueryPacket { querySenderEthernetAddress = sha+ , querySenderIPAddress = spa+ , queryTargetIPAddress = tpa+ } + ) --- | 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) +arpReply :: EthernetAddress -- ^ source hardware address+ -> IPAddress -- ^ source IP address+ -> EthernetAddress -- ^ target hardware address+ -> IPAddress -- ^ target IP address+ -> EthernetFrame+arpReply sha spa tha tpa = hCons hdr (hCons (ARPInEthernet ( body)) hNil)+ where hdr = EthernetHeader { destMACAddress = tha+ , sourceMACAddress = sha+ , typeCode = ethTypeARP + } + body = ARPReply (ARPReplyPacket { replySenderEthernetAddress = sha+ , replySenderIPAddress = spa+ , replyTargetEthernetAddress = tha+ , replyTargetIPAddress = tpa+ } + ) --- | 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 :: Strict.Get EthernetFrame getEthernetFrame = do - hdr <- getEthHeader+ hdr <- {-# SCC "getEthHeader" #-} getEthHeader+ -- r <- Strict.remaining 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)+ then do ipPacket <- getIPPacket+ return $ hCons hdr (hCons (IPInEthernet ipPacket) hNil) + else if typeCode hdr == ethTypeARP+ then do mArpPacket <- getARPPacket+ case mArpPacket of+ Just arpPacket -> return $ hCons hdr (hCons (ARPInEthernet arpPacket) hNil)+ Nothing -> error "unknown ethernet frame"+-- do body <- Strict.getByteString r+-- return $ hCons hdr (hCons (UninterpretedEthernetBody B.empty) hNil) + else error "unknown ethernet frame" + --do body <- Strict.getByteString r+ -- return $ hCons hdr (hCons (UninterpretedEthernetBody B.empty) hNil) +{-# INLINE getEthernetFrame #-} +getEthernetFrame2 :: Int -> Binary.Get EthernetFrame+getEthernetFrame2 total = do + hdr <- getEthHeader2+ soFar <- Binary.bytesRead + let r = total - fromIntegral soFar + if typeCode hdr == ethTypeIP+ then do ipPacket <- getIPPacket2+ return $ hCons hdr (hCons (IPInEthernet ipPacket) hNil) + else if typeCode hdr == ethTypeARP+ then do mArpPacket <- getARPPacket2+ case mArpPacket of+ Just arpPacket -> return $ hCons hdr (hCons (ARPInEthernet arpPacket) hNil)+ Nothing -> + do body <- Binary.getByteString r+ return $ hCons hdr (hCons (UninterpretedEthernetBody B.empty) hNil) + else do body <- Binary.getByteString r+ return $ hCons hdr (hCons (UninterpretedEthernetBody B.empty) hNil) ++ -- | Parser for Ethernet headers.-getEthHeader :: GetE EthernetHeader-getEthHeader = do - dstAddr <- lift getEthernetAddress- srcAddr <- lift getEthernetAddress- tcode <- lift getWord16be+getEthHeader2 :: Binary.Get EthernetHeader+getEthHeader2 = do + dstAddr <- getEthernetAddress2+ srcAddr <- getEthernetAddress2+ tcode <- Binary.getWord16be if tcode < typeEth2Cutoff - then throwError ("tcode of ethernet header is not greater than " ++ show typeEth2Cutoff)+ then error "don't know how to parse this kind of ethernet frame" else if (tcode == ethTypeVLAN) - then do x <- lift getWord16be- etherType <- lift getWord16be+ then do x <- Binary.getWord16be+ etherType <- Binary.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) +getEthHeader :: Strict.Get EthernetHeader+getEthHeader = do + dstAddr <- getEthernetAddress+ srcAddr <- getEthernetAddress+ tcode <- Strict.getWord16be+ if tcode >= typeEth2Cutoff + then if (tcode /= ethTypeVLAN) + then return (EthernetHeader dstAddr srcAddr tcode)+ else do x <- Strict.getWord16be+ etherType <- Strict.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 Strict.zero+{-# INLINE getEthHeader #-}++ -- | Unparser for Ethernet headers.-putEthHeader :: EthernetHeader -> Put +putEthHeader :: EthernetHeader -> Strict.Put putEthHeader (EthernetHeader dstAddr srcAddr tcode) = do putEthernetAddress dstAddr putEthernetAddress srcAddr- putWord16be tcode+ Strict.putWord16be tcode putEthHeader (Ethernet8021Q dstAddr srcAddr tcode pcp cfi vid) = do putEthernetAddress dstAddr putEthernetAddress srcAddr- putWord16be ethTypeVLAN- putWord16be x- putWord16be tcode+ Strict.putWord16be ethTypeVLAN+ Strict.putWord16be x+ Strict.putWord16be tcode where x = let y = shiftL (fromIntegral pcp :: Word16) 13 y' = if cfi then setBit y 12 else y in y' + fromIntegral vid +putEthFrame :: EthernetFrame -> Strict.Put+putEthFrame (HCons hdr (HCons body HNil)) = + do putEthHeader hdr+ case body of+ IPInEthernet ipPacket -> error "put method not yet supported for IP packets"+ ARPInEthernet arpPacket -> error "put method not yet supported for ARP packets"+ UninterpretedEthernetBody bs -> Strict.putByteString bs + ethTypeIP, ethTypeARP, ethTypeLLDP, ethTypeVLAN, typeEth2Cutoff :: EthernetTypeCode ethTypeIP = 0x0800 ethTypeARP = 0x0806@@ -153,33 +257,6 @@ 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
src/Nettle/IPv4/IPAddress.hs view
@@ -1,46 +1,51 @@+{-# LANGUAGE BangPatterns #-}+ 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+import Data.Binary.Strict.Get +import qualified Nettle.OpenFlow.StrictPut as Strict+import qualified Data.Binary.Get as Binary + newtype IPAddress = IPAddress Word32 deriving (Read, Eq, Show, Ord) type IPAddressPrefix = (IPAddress, PrefixLength) type PrefixLength = Word8 ipAddressToWord32 :: IPAddress -> Word32 ipAddressToWord32 (IPAddress a) = a+{-# INLINE ipAddressToWord32 #-} 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+{-# INLINE getIPAddress #-} -putIPAddress :: IPAddress -> Put-putIPAddress (IPAddress a) = putWord32be a+getIPAddress2 :: Binary.Get IPAddress+getIPAddress2 = Binary.getWord32be >>= return . IPAddress +putIPAddress :: IPAddress -> Strict.Put+putIPAddress (IPAddress a) = Strict.putWord32be a+ (//) :: IPAddress -> PrefixLength -> IPAddressPrefix (IPAddress a) // len = (IPAddress a', len)- where a' = a .&. mask- mask = foldl setBit (0 :: Word32) [(32-fromIntegral len)..31]+ where !a' = a .&. mask+ !mask = complement (2^(32 - fromIntegral len) - 1) 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-+addressPart (IPAddress a,l) = IPAddress a+{-# INLINE addressPart #-}+ prefixLength :: IPAddressPrefix -> PrefixLength prefixLength (_,l) = l+{-# INLINE prefixLength #-} maxPrefixLen :: Word8 maxPrefixLen = 32
src/Nettle/IPv4/IPPacket.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, RecordWildCards #-}+{-# LANGUAGE TypeSynonymInstances, TypeOperators, MultiParamTypeClasses, FunctionalDependencies, RecordWildCards #-}+{-# LANGUAGE BangPatterns #-} {-| @@ -35,9 +36,15 @@ , ipTypeUdp , ipTypeIcmp , IPBody(..)+ , fromTCPPacket+ , fromUDPPacket+ , withIPPacket+ , foldIPPacket+ , foldIPBody -- * Parsers , getIPPacket+ , getIPPacket2 , getIPHeader , ICMPHeader , ICMPType@@ -49,31 +56,29 @@ , 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+import Data.HList+import Data.Binary.Strict.Get+import Data.ByteString as S+import qualified Data.Binary.Get as Binary -- | An IP packet consists of a header and a body.-data IPPacket = IPPacket IPHeader IPBody- deriving (Show,Eq)+type IPPacket = IPHeader :*: IPBody :*: HNil + -- | 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+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) @@ -91,26 +96,36 @@ -- | 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+data IPBody = TCPInIP TCPHeader+ | UDPInIP UDPHeader S.ByteString+ | 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+foldIPPacket :: (IPHeader -> IPBody -> a) -> IPPacket -> a+foldIPPacket f (HCons h (HCons b HNil)) = f h b +foldIPBody :: (TCPHeader -> a) -> (UDPHeader -> a) -> (ICMPHeader -> a) -> (B.ByteString -> a) -> IPBody -> a+foldIPBody f g h k (TCPInIP x) = f x+foldIPBody f g h k (UDPInIP x body) = g x+foldIPBody f g h k (ICMPInIP x) = h x+foldIPBody f g h k (UninterpretedIPBody x) = k x ++fromTCPPacket :: IPBody -> Maybe (TCPHeader :*: HNil)+fromTCPPacket (TCPInIP body) = Just (hCons body hNil)+fromTCPPacket _ = Nothing+++fromUDPPacket :: IPBody -> Maybe (UDPHeader :*: S.ByteString :*: HNil)+fromUDPPacket (UDPInIP hdr body) = Just (hCons hdr (hCons body hNil))+fromUDPPacket _ = Nothing+++withIPPacket :: HList l => (IPBody -> Maybe l) -> IPPacket -> Maybe (IPHeader :*: l)+withIPPacket f pkt = fmap (hCons (hOccurs pkt)) (f (hOccurs pkt))+ getIPHeader :: Get IPHeader getIPHeader = do b1 <- getWord8@@ -130,24 +145,67 @@ , totalLength = fromIntegral totalLen , dscp = shiftR diffServ 2 } )+{-# INLINE getIPHeader #-} +getIPHeader2 :: Binary.Get IPHeader+getIPHeader2 = do + b1 <- Binary.getWord8+ diffServ <- Binary.getWord8+ totalLen <- Binary.getWord16be+ ident <- Binary.getWord16be+ flagsAndFragOffset <- Binary.getWord16be+ ttl <- Binary.getWord8+ nwproto <- getIPProtocol2+ hdrChecksum <- Binary.getWord16be+ nwsrc <- getIPAddress2+ nwdst <- getIPAddress2+ return (IPHeader { ipSrcAddress = nwsrc + , ipDstAddress = nwdst + , ipProtocol = nwproto+ , headerLength = fromIntegral (b1 .&. 0x0f)+ , totalLength = fromIntegral totalLen+ , dscp = shiftR diffServ 2+ } )++ getIPProtocol :: Get IPProtocol getIPProtocol = getWord8+{-# INLINE getIPProtocol #-} -getFragOffset :: Get FragOffset-getFragOffset = getWord16be+getIPProtocol2 :: Binary.Get IPProtocol +getIPProtocol2 = Binary.getWord8 -getIPPacket :: Get IPPacket++getIPPacket :: Get IPPacket getIPPacket = do - hdr <- getIPHeader+ hdr <- {-# SCC "getIPPacket1" #-} getIPHeader+ body <- {-# SCC "getIPPacket2" #-} getIPBody hdr+ return body+ where getIPBody hdr@(IPHeader {..}) + | ipProtocol == ipTypeTcp = {-# SCC "getIPPacket3" #-} getTCPHeader >>= return . (\tcpHdr -> hCons hdr (hCons (TCPInIP tcpHdr) hNil))+ | ipProtocol == ipTypeUdp = {-# SCC "getIPPacket4" #-} + do udpHdr <- getUDPHeader + body <- getByteString (fromIntegral (totalLength - (4 * headerLength)) - 4)+ return (hCons hdr (hCons (UDPInIP udpHdr body) hNil))+ | ipProtocol == ipTypeIcmp = {-# SCC "getIPPacket5" #-} getICMPHeader >>= return . (\icmpHdr -> hCons hdr (hCons (ICMPInIP icmpHdr) hNil))+ | otherwise = {-# SCC "getIPPacket6" #-} + getByteString (fromIntegral (totalLength - (4 * headerLength))) >>= + return . (\bs -> hCons hdr (hCons (UninterpretedIPBody (B.fromChunks [bs])) hNil))+{-# INLINE getIPPacket #-}+ +getIPPacket2 :: Binary.Get IPPacket +getIPPacket2 = do + hdr <- getIPHeader2 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+ return body+ where getIPBody hdr@(IPHeader {..}) + | ipProtocol == ipTypeTcp = getTCPHeader2 >>= return . (\tcpHdr -> hCons hdr (hCons (TCPInIP tcpHdr) hNil))+ | ipProtocol == ipTypeUdp = do udpHdr <- getUDPHeader2 + body <- Binary.getByteString (fromIntegral (totalLength - (4 * headerLength)))+ return (hCons hdr (hCons (UDPInIP udpHdr body) hNil))+ | ipProtocol == ipTypeIcmp = getICMPHeader2 >>= return . (\icmpHdr -> hCons hdr (hCons (ICMPInIP icmpHdr) hNil))+ | otherwise = Binary.getByteString (fromIntegral (totalLength - (4 * headerLength))) >>= + return . (\bs -> hCons hdr (hCons (UninterpretedIPBody (B.fromChunks [bs])) hNil)) -- Transport Header @@ -161,7 +219,15 @@ icmp_code <- getWord8 skip 6 return (icmp_type, icmp_code)+{-# INLINE getICMPHeader #-} +getICMPHeader2 :: Binary.Get ICMPHeader+getICMPHeader2 = do + icmp_type <- Binary.getWord8+ icmp_code <- Binary.getWord8+ Binary.skip 6+ return (icmp_type, icmp_code)+ type TCPHeader = (TCPPortNumber, TCPPortNumber) type TCPPortNumber = Word16 @@ -170,7 +236,14 @@ srcp <- getWord16be dstp <- getWord16be return (srcp,dstp)+{-# INLINE getTCPHeader #-} +getTCPHeader2 :: Binary.Get TCPHeader+getTCPHeader2 = do + srcp <- Binary.getWord16be+ dstp <- Binary.getWord16be+ return (srcp,dstp)+ type UDPHeader = (UDPPortNumber, UDPPortNumber) type UDPPortNumber = Word16 @@ -178,5 +251,12 @@ getUDPHeader = do srcp <- getWord16be dstp <- getWord16be+ return (srcp,dstp)+{-# INLINE getUDPHeader #-} ++getUDPHeader2 :: Binary.Get UDPHeader+getUDPHeader2 = do + srcp <- Binary.getWord16be+ dstp <- Binary.getWord16be return (srcp,dstp)
+ src/Nettle/OpenFlow.hs view
@@ -0,0 +1,33 @@+module Nettle.OpenFlow (+ module Nettle.OpenFlow.Action+ , module Nettle.OpenFlow.Error+ , module Nettle.OpenFlow.FlowTable+ , module Nettle.OpenFlow.Match+ , module Nettle.OpenFlow.Messages+ , module Nettle.OpenFlow.MessagesBinary+ , module Nettle.OpenFlow.Packet+ , module Nettle.OpenFlow.Port+ , module Nettle.OpenFlow.Statistics+ , module Nettle.OpenFlow.Switch+ , module Nettle.Ethernet.EthernetAddress+ , module Nettle.Ethernet.EthernetFrame+ , module Nettle.IPv4.IPAddress+ , module Nettle.IPv4.IPPacket+ , module Data.HList+ ) where++import Nettle.OpenFlow.Action+import Nettle.OpenFlow.Error+import Nettle.OpenFlow.FlowTable+import Nettle.OpenFlow.Match+import Nettle.OpenFlow.Messages+import Nettle.OpenFlow.MessagesBinary+import Nettle.OpenFlow.Packet+import Nettle.OpenFlow.Port+import Nettle.OpenFlow.Statistics+import Nettle.OpenFlow.Switch+import Nettle.Ethernet.EthernetAddress+import Nettle.Ethernet.EthernetFrame+import Nettle.IPv4.IPAddress+import Nettle.IPv4.IPPacket+import Data.HList
src/Nettle/OpenFlow/Action.hs view
@@ -6,25 +6,18 @@ , 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)@@ -45,14 +38,10 @@ | 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) @@ -68,18 +57,14 @@ | 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) @@ -99,10 +84,8 @@ -- 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@.
src/Nettle/OpenFlow/FlowTable.hs view
@@ -7,9 +7,7 @@ module Nettle.OpenFlow.FlowTable ( FlowTableID , FlowMod (..)-#if OPENFLOW_VERSION==1 , Cookie-#endif , Priority , TimeOut (..) , FlowRemoved (..)@@ -28,55 +26,37 @@ 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 @@ -88,10 +68,7 @@ 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@@ -105,41 +82,18 @@ -- | 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 }+data FlowRemoved = FlowRemovedRecord { 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)
src/Nettle/OpenFlow/Match.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, DisambiguateRecordFields, RecordWildCards, NamedFieldPuns #-}+{-# LANGUAGE BangPatterns #-} module Nettle.OpenFlow.Match ( Match (..)@@ -6,34 +7,33 @@ , isExactMatch , getExactMatch , frameToExactMatch+ , frameToExactMatchNoPort , ofpVlanNone , matches ) where import Nettle.Ethernet.EthernetAddress import Nettle.Ethernet.EthernetFrame +import Nettle.Ethernet.AddressResolutionProtocol 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+import Data.HList +import qualified Data.Binary.Strict.Get as Strict -- | 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 }+data Match = Match { inPort :: !(Maybe PortID), + srcEthAddress, dstEthAddress :: !(Maybe EthernetAddress), + vLANID :: !(Maybe VLANID), + vLANPriority :: !(Maybe VLANPriority), + ethFrameType :: !(Maybe EthernetTypeCode),+ ipTypeOfService :: !(Maybe IP.IPTypeOfService), + matchIPProtocol :: !(Maybe IP.IPProtocol), + srcIPAddress, dstIPAddress :: !IPAddressPrefix,+ srcTransportPort, dstTransportPort :: !(Maybe IP.TransportPort) } deriving (Show,Read,Eq) @@ -43,14 +43,10 @@ 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, + matchIPProtocol = Nothing, srcIPAddress = defaultIPPrefix, dstIPAddress = defaultIPPrefix, srcTransportPort = Nothing, @@ -64,14 +60,10 @@ (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) &&+ (isJust matchIPProtocol) && (prefixIsExact srcIPAddress) && (prefixIsExact dstIPAddress) && (isJust srcTransportPort) &&@@ -79,58 +71,69 @@ 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+frameToExactMatch inPort frame = foldEthernetFrame frameToMatch frame+ where m0 = matchAny { inPort = Just inPort }+ frameToMatch hdr body = + let m1 = addEthHeaders m0 hdr+ in foldEthernetBody (addIPHeaders m1) (addARPHeaders m1) (const m1) body ++frameToExactMatchNoPort :: EthernetFrame -> Match+frameToExactMatchNoPort frame = foldEthernetFrame frameToMatch frame+ where frameToMatch hdr body = + let m1 = addEthHeaders matchAny hdr+ in foldEthernetBody (addIPHeaders m1) (addARPHeaders m1) (const m1) body ++++addEthHeaders :: Match -> EthernetHeader -> Match +addEthHeaders m0 (EthernetHeader {..}) = + m0 { srcEthAddress = Just sourceMACAddress+ , dstEthAddress = Just destMACAddress+ , ethFrameType = Just typeCode+ , vLANID = Just (fromIntegral ofpVlanNone)+ , vLANPriority = Just 0+ }+addEthHeaders m0 (Ethernet8021Q {..}) =+ m0 { srcEthAddress = Just sourceMACAddress+ , dstEthAddress = Just destMACAddress+ , vLANID = Just vlanId+ , ethFrameType = Just typeCode+ , vLANPriority = Just priorityCodePoint+ }+++addIPHeaders :: Match -> IP.IPPacket -> Match +addIPHeaders m1 pkt = IP.foldIPPacket g pkt+ where g iphdr ipBdy = IP.foldIPBody f' f' h' (const m2) ipBdy+ where m2 = m1 { matchIPProtocol = Just (IP.ipProtocol iphdr)+ , srcIPAddress = IP.ipSrcAddress iphdr // 32 + , dstIPAddress = IP.ipDstAddress iphdr // 32 + , ipTypeOfService = Just (IP.dscp iphdr) }- 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+ f' (src,dst) = m2 { srcTransportPort = Just src, + dstTransportPort = Just dst } + h' (icmpType,icmpCode) = m2 { srcTransportPort = Just (fromIntegral icmpType), + dstTransportPort = Just 0 } +addARPHeaders :: Match -> ARPPacket -> Match+addARPHeaders m (ARPQuery (ARPQueryPacket {..})) = + m { matchIPProtocol = Just 1 + , srcIPAddress = querySenderIPAddress // 32+ , dstIPAddress = queryTargetIPAddress // 32 + }+addARPHeaders m (ARPReply (ARPReplyPacket {..})) =+ m { matchIPProtocol = Just 2 + , srcIPAddress = replySenderIPAddress // 32+ , dstIPAddress = replyTargetIPAddress // 32 + }++ -- | Utility function to get an exact match corresponding to -- a packet (as given by a byte sequence).-getExactMatch :: PortID -> GetE Match+getExactMatch :: PortID -> Strict.Get Match getExactMatch inPort = do frame <- getEthernetFrame return (frameToExactMatch inPort frame)@@ -138,74 +141,62 @@ -- | 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+matches (inPort, frame) (m@Match { inPort=inPort', ipTypeOfService=ipTypeOfService',..}) = 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 matchesIPProtocol matchIPProtocol, maybe True matchesIPToS ipTypeOfService',-#endif matchesIPSourcePrefix srcIPAddress, matchesIPDestPrefix dstIPAddress, maybe True matchesSrcTransportPort srcTransportPort, maybe True matchesDstTransportPort dstTransportPort ] where+ ethHeader = hOccurs frame matchesInPort p = p == inPort- matchesSrcEthAddress a = IP.sourceAddress frame == a - matchesDstEthAddress a = IP.destAddress frame == a + matchesSrcEthAddress a = sourceMACAddress ethHeader == a + matchesDstEthAddress a = destMACAddress ethHeader == 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+ 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 + case eth_ip_packet frame of + Just pkt -> IP.ipProtocol (hOccurs pkt) == protCode+ _ -> True matchesIPToS tos =- case ethBody of - IPInEthernet (IP.IPPacket (IP.IPHeader {..}) _) -> tos == dscp- _ -> True-#endif + case eth_ip_packet frame of + Just pkt -> tos == IP.dscp (hOccurs pkt)+ _ -> True matchesIPSourcePrefix prefix = - case ethBody of - IPInEthernet ipPkt -> IP.sourceAddress ipPkt `elemOfPrefix` prefix- _ -> True+ case eth_ip_packet frame of + Just pkt -> IP.ipSrcAddress (hOccurs pkt) `elemOfPrefix` prefix+ Nothing -> True matchesIPDestPrefix prefix = - case ethBody of - IPInEthernet ipPkt -> IP.destAddress ipPkt `elemOfPrefix` prefix- _ -> True+ case eth_ip_packet frame of + Just pkt -> IP.ipSrcAddress (hOccurs pkt) `elemOfPrefix` prefix+ Nothing -> True matchesSrcTransportPort sp = - case ethBody of - IPInEthernet (IP.IPPacket ipHeader ipBody) -> - case ipBody of + case eth_ip_packet frame of+ Just pkt -> + case hOccurs pkt of IP.TCPInIP (srcPort, _) -> srcPort == sp- IP.UDPInIP (srcPort, _) -> srcPort == sp+ IP.UDPInIP (srcPort, _) body -> srcPort == sp _ -> True- _ -> True+ Nothing -> True matchesDstTransportPort dp = - case ethBody of - IPInEthernet (IP.IPPacket ipHeader ipBody) -> - case ipBody of + case eth_ip_packet frame of+ Just ipPacket ->+ case hOccurs ipPacket of IP.TCPInIP (_, dstPort) -> dstPort == dp- IP.UDPInIP (_, dstPort) -> dstPort == dp- _ -> True- _ -> True+ IP.UDPInIP (_, dstPort) body -> dstPort == dp+ _ -> True+ Nothing -> True
src/Nettle/OpenFlow/Messages.hs view
@@ -27,32 +27,32 @@ -- | 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+ | 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 | BarrierReply -- ^ Switch responds that a barrier has been processed-#endif+ | QueueConfigReply !QueueConfigReply 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+ | 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+ | 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 | BarrierRequest -- ^ Controller requests a barrier-#endif+ | SetConfig+ | Vendor+ | GetQueueConfig !QueueConfigRequest deriving (Show,Eq)
src/Nettle/OpenFlow/MessagesBinary.hs view
@@ -1,1913 +1,1882 @@ {-# 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+{-# LANGUAGE BangPatterns #-}++-- | 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 (+-- messageDriver2+ -- * Parsing and unparsing methods+ getHeader+ , getSCMessage + , getSCMessageBody+ , putSCMessage+ , getCSMessage+ , getCSMessageBody + , putCSMessage+ + , OFPHeader(..)+ ) 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 Control.Monad (when)+import Control.Exception+import Data.Word+import Data.Bits+import Nettle.OpenFlow.StrictPut+import Data.Binary.Strict.Get+import qualified Data.ByteString 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.Set (Set)+import qualified Data.Set as Set+import Data.Bimap (Bimap, (!), (!>))+import qualified Data.Bimap as Bimap+import System.IO+import Control.Concurrent (yield)+import Data.IORef+import Data.Char (ord)++type MessageTypeCode = Word8++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+++-- | Parser for @SCMessage@s+getSCMessage :: Get (M.TransactionID, M.SCMessage) +getSCMessage = do hdr <- getHeader+ getSCMessageBody hdr+++-- | Parser for @CSMessage@s+getCSMessage :: Get (M.TransactionID, M.CSMessage)+getCSMessage = do hdr <- getHeader+ getCSMessageBody hdr+++-- | Unparser for @SCMessage@s+putSCMessage :: (M.TransactionID, M.SCMessage) -> Put +putSCMessage (xid, msg) = + case msg of + M.SCHello -> putH ofptHello headerSize++ M.SCEchoRequest bytes -> do putH ofptEchoRequest (headerSize + length bytes) + putWord8s bytes++ M.SCEchoReply bytes -> do putH ofptEchoReply (headerSize + length bytes) + putWord8s bytes+ M.PacketIn pktInfo -> do let bodyLen = packetInMessageBodyLen pktInfo+ putH ofptPacketIn (headerSize + bodyLen)+ putPacketInRecord pktInfo+ M.Features features -> do putH ofptFeaturesReply (headerSize + 24 + 48 * length (ports features))+ putSwitchFeaturesRecord features+ M.Error error -> do putH ofptError (headerSize + 2 + 2)+ putSwitchError error + where vid = ofpVersion+ putH tcode len = putHeader (OFPHeader vid tcode (fromIntegral len) xid) ++packetInMessageBodyLen :: PacketInfo -> Int+packetInMessageBodyLen pktInfo = 10 + fromIntegral (packetLength pktInfo)++putPacketInRecord :: PacketInfo -> Put+putPacketInRecord pktInfo@(PacketInfo {..}) = + do putWord32be $ maybe (-1) id bufferID+ putWord16be $ fromIntegral packetLength + putWord16be receivedOnPort+ putWord8 $ reason2Code reasonSent+ putWord8 0+ putByteString packetData +++{- 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+{-# INLINE getHeader #-} + +-- Get SCMessage body+{-# INLINE getSCMessageBody #-} +getSCMessageBody :: OFPHeader -> Get (M.TransactionID, M.SCMessage)+getSCMessageBody hdr@(OFPHeader {..}) = + if msgType == ofptPacketIn + then do packetInRecord <- getPacketInRecord len+ return (msgTransactionID, M.PacketIn packetInRecord)+ 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 == ofptHello + then return (msgTransactionID, M.SCHello)+ 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)+ else if msgType == ofptFlowRemoved+ then do body <- getFlowRemovedRecord + return (msgTransactionID, M.FlowRemoved body)+ else if msgType == ofptBarrierReply+ then return (msgTransactionID, M.BarrierReply)+ else if msgType == ofptStatsReply+ then do body <- getStatsReply len+ return (msgTransactionID, M.StatsReply body)+ else if msgType == ofptQueueGetConfigReply+ then do qcReply <- getQueueConfigReply len+ return (msgTransactionID, M.QueueConfigReply qcReply)+ else error ("Unrecognized message header: " ++ show hdr)+ where len = fromIntegral msgLength++getCSMessageBody :: OFPHeader -> Get (M.TransactionID, M.CSMessage)+getCSMessageBody header@(OFPHeader {..}) = + if msgType == ofptPacketOut + then do packetOut <- getPacketOut len+ return (msgTransactionID, M.PacketOut packetOut)+ else if msgType == ofptFlowMod+ then do mod <- getFlowMod len+ return (msgTransactionID, M.FlowMod mod)+ else if msgType == ofptHello + then return (msgTransactionID, M.CSHello)+ else if msgType == ofptEchoRequest+ then do bytes <- getWord8s (len - headerSize)+ return (msgTransactionID, M.CSEchoRequest bytes)+ else if msgType == ofptEchoReply+ then do bytes <- getWord8s (len - headerSize)+ return (msgTransactionID, M.CSEchoReply bytes)+ else if msgType == ofptFeaturesRequest+ then return (msgTransactionID, M.FeaturesRequest)+ else if msgType == ofptSetConfig+ then do _ <- getSetConfig + return (msgTransactionID, M.SetConfig)+ else if msgType == ofptVendor + then do () <- getVendorMessage+ return (msgTransactionID, M.Vendor)+ else error ("Unrecognized message type with header: " ++ show header)+ where len = fromIntegral msgLength++-----------------------+-- Queue Config parser+-----------------------+getQueueConfigReply :: Int -> Get QueueConfigReply+getQueueConfigReply len = + do portID <- getWord16be + skip 6+ qs <- getQueues 16 []+ return (PortQueueConfig portID qs)+ where + getQueues pos acc = + if pos < len+ then do (q, n) <- getQueue+ let pos' = pos + n+ pos' `seq` getQueues pos' (q:acc)+ else return acc+ getQueue = + do qid <- getWord32be + qdlen <- getWord16be+ skip 2+ qprops <- getQueueProps qdlen 8 [] -- at byte 8 because of ofp_packet_queue header and len includes header (my guess).+ return (QueueConfig qid qprops, fromIntegral qdlen)+ where + getQueueProps qdlen pos acc = + if pos < qdlen+ then do (prop, propLen) <- getQueueProp+ let pos' = pos + propLen+ pos' `seq` getQueueProps qdlen pos' (prop : acc)+ else return acc+ getQueueProp = + do propType <- getWord16be+ propLen <- getWord16be + skip 4+ when (propType /= ofpqtMinRate) (error ("Unexpected queue property type code " ++ show propType))+ rate <- getWord16be+ skip 6+ let rate' = if rate > 1000 then Disabled else Enabled rate+ return (MinRateQueue rate', propLen)+ + +ofpqtMinRate :: Word16 +ofpqtMinRate = 1+----------------------+-- Set Config parser+----------------------+getSetConfig :: Get (Word16, Word16) +getSetConfig = do flags <- getWord16be+ missSendLen <- getWord16be+ return (flags, missSendLen)+ +------------------------------------------- +-- Vendor parser +------------------------------------------- +getVendorMessage :: Get () +getVendorMessage + = do r <- remaining + getByteString r+ return ()+ +-------------------------------------------+-- SWITCH FEATURES PARSER +-------------------------------------------++putSwitchFeaturesRecord (SwitchFeatures {..}) = do+ putWord64be switchID+ putWord32be $ fromIntegral packetBufferSize+ putWord8 $ fromIntegral numberFlowTables+ sequence_ $ replicate 3 (putWord8 0)+ putWord32be $ switchCapabilitiesBitVector capabilities+ putWord32be $ actionTypesBitVector supportedActions+ sequence_ [ putPhyPort p | p <- ports ]++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++putPhyPort :: Port -> Put+putPhyPort (Port {..}) = + do putWord16be portID+ putEthernetAddress portAddress+ mapM_ putWord8 $ take ofpMaxPortNameLen (map (fromIntegral . ord) portName ++ repeat 0)+ putWord32be $ portConfigsBitVector portConfig+ putWord32be $ portState2Code portLinkDown portSTPState+ putWord32be $ featuresBitVector $ maybe [] id portCurrentFeatures+ putWord32be $ featuresBitVector $ maybe [] id portAdvertisedFeatures + putWord32be $ featuresBitVector $ maybe [] id portSupportedFeatures + putWord32be $ featuresBitVector $ maybe [] id portPeerFeatures + ++getPhyPort :: Get Port+getPhyPort = do + port_no <- getWord16be+ 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+ }++ofpMaxPortNameLen = 16+++featuresBitVector :: [PortFeature] -> Word32+featuresBitVector = foldl (\v f -> v .|. featureBitMask f) 0++featureBitMask :: PortFeature -> Word32+featureBitMask feat = + case lookup feat featurePositions of + Nothing -> error "unexpected port feature"+ Just i -> bit i++decodePortFeatureSet :: Word32 -> Maybe [PortFeature]+decodePortFeatureSet word + | word == 0 = Nothing+ | otherwise = Just $ concat [ if word `testBit` position then [feat] else [] | (feat, position) <- featurePositions ]++featurePositions :: [(PortFeature, Int)]+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++portState2Code :: Bool -> SpanningTreePortState -> Word32+portState2Code isUp stpState = + let b1 = if isUp then ofppsLinkDown else 0+ b2 = case stpState of+ STPListening -> ofppsStpListen+ STPLearning -> ofppsStpLearn+ STPForwarding -> ofppsStpForward+ STPBlocking -> ofppsStpBlock+ in b1 .|. b2+ +bitMap2PortConfigAttributeSet :: Word32 -> [PortConfigAttribute]+bitMap2PortConfigAttributeSet bmap = filter inBMap $ enumFrom $ toEnum 0+ where inBMap attr = let mask = portAttribute2BitMask attr + in mask .&. bmap == mask++portConfigsBitVector :: [PortConfigAttribute] -> Word32+portConfigsBitVector = foldl (\v a -> v .|. portAttribute2BitMask a) 0++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++switchCapabilitiesBitVector :: [SwitchCapability] -> Word32+switchCapabilitiesBitVector = + foldl (\vector c -> vector .|. switchCapability2BitMask c) 0++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++actionTypesBitVector :: [ActionType] -> Word32+actionTypesBitVector = foldl (\v a -> v .|. actionType2BitMask a) 0++{-+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)+-}++code2ActionType :: Word16 -> ActionType+code2ActionType !code = + case code of+ 0 -> OutputToPortType+ 1 -> SetVlanVIDType+ 2 -> SetVlanPriorityType+ 3 -> StripVlanHeaderType+ 4 -> SetEthSrcAddrType+ 5 -> SetEthDstAddrType+ 6 -> SetIPSrcAddrType+ 7 -> SetIPDstAddrType+ 8 -> SetIPTypeOfServiceType+ 9 -> SetTransportSrcPortType+ 10 -> SetTransportDstPortType+ 11 -> EnqueueType+ 0xffff -> VendorActionType +{-# INLINE code2ActionType #-}++actionType2Code :: ActionType -> Word16+actionType2Code OutputToPortType = 0+actionType2Code SetVlanVIDType = 1+actionType2Code SetVlanPriorityType = 2+actionType2Code StripVlanHeaderType = 3+actionType2Code SetEthSrcAddrType = 4+actionType2Code SetEthDstAddrType = 5+actionType2Code SetIPSrcAddrType = 6+actionType2Code SetIPDstAddrType = 7+actionType2Code SetIPTypeOfServiceType = 8+actionType2Code SetTransportSrcPortType = 9+actionType2Code SetTransportDstPortType = 10+actionType2Code EnqueueType = 11+actionType2Code VendorActionType = 0xffff+{-# INLINE actionType2Code #-} ++{- + actionType2Code a = + case Bimap.lookup a actionType2CodeBijection of+ Just x -> x+ Nothing -> error ("In actionType2Code: encountered unknown action type: " ++ show a)+-}++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)+ ]+++actionType2BitMask :: ActionType -> Word32+actionType2BitMask = shiftL 1 . fromIntegral . actionType2Code ++------------------------------------------+-- Packet In Parser+------------------------------------------+{-# INLINE getPacketInRecord #-} +getPacketInRecord :: Int -> Get PacketInfo+getPacketInRecord len = do + bufID <- getWord32be+ totalLen <- getWord16be+ in_port <- getWord16be+ reasonCode <- getWord8+ skip 1+ bytes <- getByteString (fromIntegral data_len)+ let reason = code2Reason reasonCode+ let mbufID = if (bufID == maxBound) then Nothing else Just bufID+ let frame = {-# SCC "getPacketInRecord1" #-} fst (runGet getEthernetFrame bytes)+ return $ PacketInfo mbufID (fromIntegral totalLen) in_port reason bytes frame+ where data_offset = 18 -- 8 + 4 + 2 + 2 + 1 + 1+ data_len = len - data_offset++{-# INLINE code2Reason #-}+code2Reason :: Word8 -> PacketInReason+code2Reason !code + | code == 0 = NotMatched+ | code == 1 = ExplicitSend+ | otherwise = error ("Received unknown packet-in reason code: " ++ show code ++ ".")++{-# INLINE reason2Code #-}+reason2Code :: PacketInReason -> Word8+reason2Code NotMatched = 0+reason2Code ExplicitSend = 1++ +++------------------------------------------+-- 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)++putSwitchError :: SwitchError -> Put+putSwitchError (BadRequest VendorNotSupported []) = + do putWord16be 1+ putWord16be 3++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 $ FlowRemovedRecord 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+ {-# INLINE action #-}+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.FlowMod mod -> do let mod'@(FlowModRecordInternal {..}) = flowModToFlowModInternal mod + putH ofptFlowMod (flowModSizeInBytes' actions')+ putFlowMod mod'+ M.PacketOut packetOut -> {-# SCC "putCSMessage1" #-}+ do putH ofptPacketOut (sendPacketSizeInBytes packetOut)+ putSendPacket packetOut+ 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.PortMod portModRecord -> do putH ofptPortMod portModLength+ putPortMod portModRecord+ M.BarrierRequest -> do putH ofptBarrierRequest headerSize+ M.StatsRequest request -> do putH ofptStatsRequest (statsRequestSize request)+ putStatsRequest request+ M.GetQueueConfig request -> do putH ofptQueueGetConfigRequest 12+ putQueueConfigRequest request+ where vid = ofpVersion+ putH tcode len = putHeader (OFPHeader vid tcode (fromIntegral len) xid) +{-# INLINE putCSMessage #-}++putQueueConfigRequest :: QueueConfigRequest -> Put+putQueueConfigRequest (QueueConfigRequest portID) = + do putWord16be portID+ putWord16be 0 --padding++------------------------------------------+-- Unparser for packet out message+------------------------------------------++sendPacketSizeInBytes :: PacketOut -> Int+sendPacketSizeInBytes (PacketOutRecord bufferIDData _ actions) = + headerSize + 4 + 2 + 2 + sum (map actionSizeInBytes actions) + fromIntegral (either (const 0) B.length bufferIDData)+++{-# INLINE putSendPacket #-}+putSendPacket :: PacketOut -> Put +putSendPacket (PacketOutRecord {..}) = do+ {-# SCC "putSendPacket1" #-} putWord32be $ either id (const (-1)) bufferIDData+ {-# SCC "putSendPacket2" #-} putWord16be (maybe ofppNone id packetInPort)+ {-# SCC "putSendPacket3" #-} putWord16be (fromIntegral actionArraySize)+ {-# SCC "putSendPacket4" #-} mapM_ putAction packetActions+ {-# SCC "putSendPacket5" #-} either (const $ return ()) putByteString bufferIDData+ where actionArraySize = {-# SCC "putSendPacket6" #-} sum $ map actionSizeInBytes packetActions++getPacketOut :: Int -> Get PacketOut+getPacketOut len = do + bufID' <- getWord32be+ port' <- getWord16be+ actionArraySize' <- getWord16be+ actions <- getActionsOfSize (fromIntegral actionArraySize')+ x <- remaining+ packetData <- if bufID' == -1+ then let bytesOfData = len - headerSize - 4 - 2 - 2 - fromIntegral actionArraySize'+ in getByteString (fromIntegral bytesOfData)+ else return B.empty+ return $ PacketOutRecord { bufferIDData = if bufID' == -1 + then Right packetData+ else Left bufID'+ , packetInPort = if port' == ofppNone then Nothing else Just port'+ , packetActions = actions+ } + +getActionsOfSize :: Int -> Get [Action] +getActionsOfSize n + | n > 0 = do a <- getAction+ as <- getActionsOfSize (n - actionSizeInBytes a)+ return (a : as)+ | n == 0 = return []+ | n < 0 = error "bad number of actions or bad action size"+{-# INLINE getActionsOfSize #-}++------------------------------------------+-- 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']+ +getBufferID :: Get (Maybe BufferID)+getBufferID = do w <- getWord32be+ if w == -1+ then return Nothing+ else return (Just w)+ +getOutPort :: Get (Maybe PseudoPort) +getOutPort = do w <- getWord16be+ if w == ofppNone+ then return Nothing+ else return (Just (code2FakePort w))+++getFlowModInternal :: Int -> Get FlowModRecordInternal+getFlowModInternal len = + do match <- getMatch+ cookie <- getWord64be + modType <- getFlowModType+ idleTimeOut <- getTimeOutFromCode + hardTimeOut <- getTimeOutFromCode + priority <- getWord16be + mBufferID <- getBufferID+ outPort <- getOutPort+ flags <- getFlowModFlags+ let bytesInActionList = len - 72+ actions <- getActionsOfSize (fromIntegral bytesInActionList)+ return $ FlowModRecordInternal { command' = modType+ , match' = match + , actions' = actions+ , priority' = priority+ , idleTimeOut' = idleTimeOut+ , hardTimeOut' = hardTimeOut+ , flags' = flags+ , bufferID' = mBufferID+ , outPort' = outPort+ , cookie' = cookie+ } ++ +getFlowMod :: Int -> Get FlowMod+getFlowMod len = getFlowModInternal len >>= return . flowModInternal2FlowMod++flowModInternal2FlowMod :: FlowModRecordInternal -> FlowMod +flowModInternal2FlowMod (FlowModRecordInternal {..}) = + case command' of + FlowDeleteType -> DeleteFlows { match = match', outPort = outPort' }+ FlowDeleteStrictType -> DeleteExactFlow { match = match', outPort = outPort', priority = priority' }+ FlowAddType -> + if elem Emergency flags'+ then AddEmergencyFlow { match = match'+ , priority = priority'+ , actions = actions'+ , cookie = cookie'+ , overlapAllowed = elem CheckOverlap flags'+ }+ else AddFlow { match = match'+ , priority = priority'+ , actions = actions'+ , cookie = cookie'+ , idleTimeOut = fromJust idleTimeOut'+ , hardTimeOut = fromJust hardTimeOut'+ , notifyWhenRemoved = elem SendFlowRemoved flags'+ , applyToPacket = bufferID'+ , overlapAllowed = elem CheckOverlap flags'+ }+ FlowModifyType -> ModifyFlows { match = match'+ , newActions = actions'+ , ifMissingPriority = priority'+ , ifMissingCookie = cookie'+ , ifMissingIdleTimeOut = fromJust idleTimeOut'+ , ifMissingHardTimeOut = fromJust hardTimeOut'+ , ifMissingOverlapAllowed = CheckOverlap `elem` flags'+ , ifMissingNotifyWhenRemoved = SendFlowRemoved `elem` flags'+ } + FlowModifyStrictType -> ModifyExactFlow { match = match'+ , newActions = actions'+ , priority = priority'+ , ifMissingCookie = cookie'+ , ifMissingIdleTimeOut = fromJust idleTimeOut'+ , ifMissingHardTimeOut = fromJust hardTimeOut'+ , ifMissingOverlapAllowed = CheckOverlap `elem` flags'+ , ifMissingNotifyWhenRemoved = SendFlowRemoved `elem` flags'+ } +#endif++maybeTimeOutToCode :: Maybe TimeOut -> Word16+maybeTimeOutToCode Nothing = 0+maybeTimeOutToCode (Just to) = + case to of+ Permanent -> 0+ ExpireAfter t -> t+{-# INLINE maybeTimeOutToCode #-} + +getTimeOutFromCode :: Get (Maybe TimeOut)+getTimeOutFromCode = do code <- getWord16be+ if code == 0+ then return Nothing+ else return (Just (ExpireAfter code))++#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) ]+ +bitMap2FlagSet :: Word16 -> [FlowModFlag]+bitMap2FlagSet w = [ flag | (flag,mask) <- flowModFlagToBitMaskBijection, mask .&. w /= 0 ]++getFlowModFlags :: Get [FlowModFlag]+getFlowModFlags = do w <- getWord16be+ return (bitMap2FlagSet w)+#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)+ ]++getFlowModType :: Get FlowModType+getFlowModType = do code <- getWord16be+ return (flowModTypeBimap !> code)++putAction :: Action -> Put+putAction act = + case act of + (SendOutPort port) -> + do -- putWord16be 0+ -- putWord16be 8+ putWord32be 8+ putPseudoPort port+ (SetVlanVID vlanid) -> + do putWord16be 1+ putWord16be 8+ putWord16be vlanid+ putWord16be 0+ (SetVlanPriority priority) -> + do putWord16be 2+ putWord16be 8+ putWord8 priority+ putWord8 0 + putWord8 0+ putWord8 0+ (StripVlanHeader) -> + do putWord16be 3+ putWord16be 8+ putWord32be 0+ (SetEthSrcAddr addr) -> + do putWord16be 4+ putWord16be 16+ putEthernetAddress addr+ sequence_ (replicate 6 (putWord8 0))+ (SetEthDstAddr addr) -> + do putWord16be 5+ putWord16be 16+ putEthernetAddress addr+ sequence_ (replicate 6 (putWord8 0))+ (SetIPSrcAddr addr) -> + do putWord16be 6+ putWord16be 8+ putWord32be (ipAddressToWord32 addr)+ (SetIPDstAddr addr) -> + do putWord16be 7+ putWord16be 8+ putWord32be (ipAddressToWord32 addr)+ (SetIPToS tos) -> + do putWord16be 8+ putWord16be 8+ putWord8 tos+ sequence_ (replicate 3 (putWord8 0))+ (SetTransportSrcPort port) -> + do putWord16be 9+ putWord16be 8+ putWord16be port+ putWord16be 0+ (SetTransportDstPort port) -> + do putWord16be 10+ putWord16be 8+ putWord16be port+ putWord16be 0+ (Enqueue port qid) ->+ do putWord16be 11+ putWord16be 16+ putWord16be port+ sequence_ (replicate 6 (putWord8 0))+ putWord32be qid+ (VendorAction vendorID bytes) -> + do let l = 2 + 2 + 4 + length bytes+ when (l `mod` 8 /= 0) (error "Vendor action must have enough data to make the action length a multiple of 8 bytes")+ putWord16be 0xffff+ putWord16be (fromIntegral l)+ putWord32be vendorID+ mapM_ putWord8 bytes++putPseudoPort :: PseudoPort -> Put+putPseudoPort (ToController maxLen) = + do putWord16be ofppController+ putWord16be maxLen+putPseudoPort port = + do putWord16be (fakePort2Code port)+ putWord16be 0+{-# INLINE putPseudoPort #-}+ +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+actionSizeInBytes (SetIPToS _) = 8 +actionSizeInBytes (SetTransportSrcPort _) = 8+actionSizeInBytes (SetTransportDstPort _) = 8+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+{-# INLINE actionSizeInBytes #-}++typeOfAction :: Action -> ActionType+typeOfAction !a =+ case a of+ SendOutPort _ -> OutputToPortType+ SetVlanVID _ -> SetVlanVIDType+ SetVlanPriority _ -> SetVlanPriorityType+ StripVlanHeader -> StripVlanHeaderType+ SetEthSrcAddr _ -> SetEthSrcAddrType+ SetEthDstAddr _ -> SetEthDstAddrType+ SetIPSrcAddr _ -> SetIPSrcAddrType+ SetIPDstAddr _ -> SetIPDstAddrType+ SetIPToS _ -> SetIPTypeOfServiceType+ SetTransportSrcPort _ -> SetTransportSrcPortType+ SetTransportDstPort _ -> SetTransportDstPortType+ Enqueue _ _ -> EnqueueType+ VendorAction _ _ -> VendorActionType +{-# INLINE typeOfAction #-}+++------------------------------------------+-- Port mod unparser+------------------------------------------++portModLength :: Word16+portModLength = 32++putPortMod :: PortMod -> Put+putPortMod (PortModRecord {..} ) = + 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+{-# INLINE fakePort2Code #-}++code2FakePort :: Word16 -> PseudoPort+code2FakePort w + | w <= 0xff00 = PhysicalPort w+ | w == ofppInPort = InPort+ | w == ofppFlood = Flood+ | w == ofppAll = AllPhysicalPorts+ | w == ofppController = ToController 0+ | w == ofppNormal = NormalSwitching+ | w == ofppTable = WithTable+ | otherwise = error ("unknown pseudo port number: " ++ show w)++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+---------------------------------------------+matchSize :: Int+matchSize = 40+++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'+ putWord16be 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+++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++match2OFPMatch :: Match -> OFPMatch+match2OFPMatch (Match {..}) + = OFPMatch { ofpm_wildcards = wildcard', + ofpm_in_port = maybe 0 id inPort,+ ofpm_dl_src = maybe nullEthAddr id srcEthAddress,+ ofpm_dl_dst = maybe nullEthAddr id dstEthAddress,+ ofpm_dl_vlan = maybe 0 id vLANID,+ ofpm_dl_vlan_pcp = maybe 0 id vLANPriority,+ ofpm_dl_type = maybe 0 id ethFrameType,+ ofpm_nw_tos = maybe 0 id ipTypeOfService,+ ofpm_nw_proto = maybe 0 id matchIPProtocol,+ ofpm_nw_src = fromIntegral $ ipAddressToWord32 $ addressPart srcIPAddress, + ofpm_nw_dst = fromIntegral $ ipAddressToWord32 $ addressPart dstIPAddress,+ ofpm_tp_src = maybe 0 id srcTransportPort,+ ofpm_tp_dst = maybe 0 id dstTransportPort }+ where + wildcard' :: Word32+ wildcard' = shiftL (fromIntegral numIgnoredBitsSrc) 8 .|. + shiftL (fromIntegral numIgnoredBitsDst) 14 .|.+ (maybe (flip setBit 0) (const id) inPort $+ maybe (flip setBit 1) (const id) vLANID $+ maybe (flip setBit 2) (const id) srcEthAddress $+ maybe (flip setBit 3) (const id) dstEthAddress $+ maybe (flip setBit 4) (const id) ethFrameType $+ maybe (flip setBit 5) (const id) matchIPProtocol $+ maybe (flip setBit 6) (const id) srcTransportPort $+ maybe (flip setBit 7) (const id) dstTransportPort $+ maybe (flip setBit 20) (const id) vLANPriority $+ maybe (flip setBit 21) (const id) ipTypeOfService $+ 0+ )+ numIgnoredBitsSrc = 32 - (prefixLength srcIPAddress) + numIgnoredBitsDst = 32 - (prefixLength dstIPAddress)+ nullEthAddr = ethernetAddress 0 0 0 0 0 0+ -----------------------------------
src/Nettle/OpenFlow/Packet.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP, DisambiguateRecordFields, RecordWildCards #-} module Nettle.OpenFlow.Packet (@@ -15,9 +16,10 @@ , bufferedAtSwitch ) where -import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString as B import Nettle.OpenFlow.Port import Nettle.OpenFlow.Action+import Nettle.Ethernet.EthernetFrame import Data.Word import Data.Maybe (isJust) @@ -26,10 +28,10 @@ -- 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+ = PacketOutRecord {+ bufferIDData :: !(Either BufferID B.ByteString), -- ^either a buffer ID or the data itself+ packetInPort :: !(Maybe PortID), -- ^the port at which the packet received, for the purposes of processing this command+ packetActions :: !ActionSequence -- ^actions to apply to the packet } deriving (Eq,Show) -- |A switch may buffer a packet that it receives. @@ -40,18 +42,18 @@ -- | 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- } + PacketOutRecord { bufferIDData = Left bufID+ , packetInPort = inPort+ , packetActions = 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- } + PacketOutRecord { bufferIDData = Right pktData+ , packetInPort = inPort+ , packetActions = actions+ } -- | Constructs a @PacketOut@ value that processes the packet referred to by the @PacketInfo@ value -- according to the specified actions. @@ -69,13 +71,15 @@ -- 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)+ 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+ enclosedFrame :: !(Either String EthernetFrame) -- ^result of parsing packetData field.+ } deriving (Show,Eq) + -- |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@@ -83,7 +87,7 @@ data PacketInReason = NotMatched | ExplicitSend deriving (Show,Read,Eq,Ord,Enum) -- | The number of bytes in a packet.-type NumBytes = Integer+type NumBytes = Int bufferedAtSwitch :: PacketInfo -> Bool bufferedAtSwitch = isJust . bufferID
src/Nettle/OpenFlow/Port.hs view
@@ -74,7 +74,7 @@ -- |A port can be configured with a @PortMod@ message. data PortMod - = PortMod { + = PortModRecord { portNumber :: PortID, -- ^ port number of port to modify hwAddr :: EthernetAddress, -- ^ hardware address of the port -- (redundant with the port number above; both are required)@@ -95,7 +95,7 @@ deriving (Show,Read,Eq,Ord,Enum) portAttributeOn :: PortID -> EthernetAddress -> PortConfigAttribute -> PortMod-portAttributeOn portID addr attr = PortMod portID addr (Map.singleton attr True)+portAttributeOn portID addr attr = PortModRecord portID addr (Map.singleton attr True) portAttributeOff :: PortID -> EthernetAddress -> PortConfigAttribute -> PortMod-portAttributeOff portID addr attr = PortMod portID addr (Map.singleton attr False)+portAttributeOff portID addr attr = PortModRecord portID addr (Map.singleton attr False)
+ src/Nettle/OpenFlow/StrictPut.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}++-- | This module provides a monad for serializing data into byte strings. +-- It provides mostly the same interface that Data.Binary.Put does. +-- However, the implementation is different. It allows for the data to be+-- serialized into an existing array of Word8 values. This differs from the Data.Binary.Put+-- data type, which allocates a Word8 array every time a value is serialized. +-- This module's implementation is useful if you want to reuse the Word8 array for many serializations.+-- In the case of an OpenFlow server, we can reuse a buffer to send messages, since we have no use +-- for the the Word8 array, except to pass it to an IO procedure to write the data to a socket or file.+module Nettle.OpenFlow.StrictPut (+ PutM, + Put, + runPut, + runPutToByteString,+ putWord8, + putWord16be, + putWord32be,+ putWord64be,+ putByteString+ ) where++import qualified Data.ByteString as S+import qualified Data.ByteString.Internal as S+import GHC.Word+import Foreign+import GHC.Exts+import System.IO.Unsafe++-- A state monad with state being the pointer to write location.+newtype PutM a = PutM { unPut :: Ptr Word8 -> IO (a, Ptr Word8) }++type Put = PutM ()++-- | Runs the Put writer with write position given+-- by the first pointer argument. Returns the number+-- of words written. +runPut :: Ptr Word8 -> Put -> IO Int+runPut ptr (PutM f) = + do (_, ptr') <- f ptr+ return (ptr' `minusPtr` ptr)++-- | Allocates a new byte string, and runs the Put writer with that byte string. +-- The first argument is an upper bound on the size of the array needed to do the serialization.+runPutToByteString :: Int -> Put -> S.ByteString+runPutToByteString maxSize put = + unsafeDupablePerformIO (S.createAndTrim maxSize (\ptr -> runPut ptr put))+ +instance Monad PutM where+ return x = PutM (\ptr -> return (x, ptr))+ {-# INLINE return #-}+ (PutM m) >>= f = PutM (\(!ptr) -> do { (a, ptr') <- m ptr ; let (PutM g) = f a in g ptr' } )+ {-# INLINE (>>=) #-}+ +putWord8 :: Word8 -> Put +putWord8 !w = PutM (\(!ptr) -> do { poke ptr w; return ((), ptr `plusPtr` 1) })+{-# INLINE putWord8 #-}++putWord16be :: Word16 -> Put+putWord16be !w = PutM f+ where f !ptr = + do poke ptr (fromIntegral (shiftr_w16 w 8) :: Word8)+ poke (ptr `plusPtr` 1) (fromIntegral (w) :: Word8)+ return ((), ptr `plusPtr` 2)+{-# INLINE putWord16be #-}++-- | Write a Word32 in big endian format+putWord32be :: Word32 -> Put+putWord32be !w = PutM f+ where f !p = + do poke p (fromIntegral (shiftr_w32 w 24) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8)+ poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8)+ poke (p `plusPtr` 3) (fromIntegral (w) :: Word8)+ return ((), p `plusPtr` 4)+{-# INLINE putWord32be #-}++-- | Write a Word64 in big endian format+putWord64be :: Word64 -> Put+#if WORD_SIZE_IN_BITS < 64+--+-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to+-- Word32, and write that+--+putWord64be !w =+ let a = fromIntegral (shiftr_w64 w 32) :: Word32+ b = fromIntegral w :: Word32+ in PutM $ \(!p) -> do+ poke p (fromIntegral (shiftr_w32 a 24) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8)+ poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8)+ poke (p `plusPtr` 3) (fromIntegral (a) :: Word8)+ poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8)+ poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8)+ poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8)+ poke (p `plusPtr` 7) (fromIntegral (b) :: Word8)+ return ((), p `plusPtr` 8)+#else+putWord64be !w = PutM $ \(!p) -> do+ poke p (fromIntegral (shiftr_w64 w 56) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8)+ poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8)+ poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8)+ poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8)+ poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8)+ poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8)+ poke (p `plusPtr` 7) (fromIntegral (w) :: Word8)+ return ((), p `plusPtr` 8)+#endif+{-# INLINE putWord64be #-}++putByteString :: S.ByteString -> Put+putByteString !bs = PutM f+ where f !ptr = + let (fp, offset, len) = S.toForeignPtr bs+ in do withForeignPtr fp $ \bsptr -> S.memcpy ptr (bsptr `plusPtr` offset) (fromIntegral len)+ return ((), ptr `plusPtr` len)+ +{-# INLINE putByteString #-}++{-# INLINE shiftr_w16 #-}+shiftr_w16 :: Word16 -> Int -> Word16+{-# INLINE shiftr_w32 #-}+shiftr_w32 :: Word32 -> Int -> Word32+{-# INLINE shiftr_w64 #-}+shiftr_w64 :: Word64 -> Int -> Word64+++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)+shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)++#if WORD_SIZE_IN_BITS < 64+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)+#endif+#endif
src/Nettle/OpenFlow/Switch.hs view
@@ -5,6 +5,12 @@ , SwitchID , SwitchCapability (..) , maxNumberPorts+ , QueueConfigRequest (..)+ , QueueConfigReply (..)+ , QueueConfig (..)+ , QueueLength+ , QueueProperty (..)+ , QueueRate (..) ) where import Data.Word@@ -35,15 +41,25 @@ | 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) - +data QueueConfigRequest = QueueConfigRequest PortID + deriving (Show,Read,Eq)++data QueueConfigReply = PortQueueConfig PortID [QueueConfig]+ deriving (Show,Read,Eq)+ +data QueueConfig = QueueConfig QueueID [QueueProperty]+ deriving (Show,Read,Eq)++type QueueLength = Word16++data QueueProperty = MinRateQueue QueueRate + deriving (Show,Read,Eq)+data QueueRate = Disabled | Enabled Word16+ deriving (Show, Read, Eq)
+ src/Nettle/Servers/Client.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE BangPatterns #-}++-- | This module provides methods to connect to an OpenFlow control server, +-- and send and receive messages to the server.+module Nettle.Servers.Client+ ( + ClientHandle + , connectToController+ , connectToHandles+ , closeClient+ , receiveControlMessage+ , sendMessage+ , flushClient+ ) where++import Network +import System.IO+import qualified Data.ByteString as S+import Data.Binary.Strict.Get+import Nettle.OpenFlow hiding (PortID)+import qualified Nettle.OpenFlow.StrictPut as Strict+import Data.Word+import Foreign++-- | Abstract type representing the state of the connection to the control server.+newtype ClientHandle = ClientHandle (Handle, Handle, ForeignPtr Word8)++-- | Established a connection to the control server with the given 'Network.HostName' +-- and 'Network.PortID' and returns its 'ClientHandle'.+connectToController :: HostName -> PortID -> IO ClientHandle+connectToController host port = + do h <- connectTo host port+ hSetBuffering h (BlockBuffering (Just (4 * 1024)))+ connectToHandles h h++-- | Creates a 'ClientHandle' based on a handle to read from and one to write to.+connectToHandles :: Handle -> Handle -> IO ClientHandle+connectToHandles h h' = + do let bufferSize = 32 * 1024+ outBufferPtr <- mallocForeignPtrBytes bufferSize :: IO (ForeignPtr Word8)+ return (ClientHandle (h,h',outBufferPtr))++-- | Close client, closing read and write handles.+closeClient :: ClientHandle -> IO ()+closeClient (ClientHandle (h,h',_)) = hClose h >> hClose h'++-- | Blocks until a new control message arrives or the connection is terminated, in which +-- the return value is 'Nothing'.+receiveControlMessage :: ClientHandle -> IO (Maybe (TransactionID, CSMessage))+receiveControlMessage (ClientHandle (h,_,_)) + = do eof <- hIsEOF h+ if eof + then return Nothing+ else do hdrbs <- S.hGet h headerSize+ when (headerSize /= S.length hdrbs) (error "error reading header")+ case fst (runGet getHeader hdrbs) of+ Left err -> error err+ Right header -> + do let expectedBodyLen = fromIntegral (msgLength header) - S.length hdrbs+ bodybs <- S.hGet h expectedBodyLen+ when (expectedBodyLen /= S.length bodybs) (error "error reading body")+ case fst (runGet (getCSMessageBody header) bodybs) of+ Left err -> error err+ Right msg -> return (Just msg)+ where headerSize = 8 +{-# INLINE receiveControlMessage #-}+ +-- | Sends a message to the controller. +sendMessage :: ClientHandle -> (TransactionID, SCMessage) -> IO ()+sendMessage (ClientHandle (_,h,fptr)) msg =+ withForeignPtr fptr $ \ptr -> + do bytes <- Strict.runPut ptr (putSCMessage msg)+ hPutBuf h ptr bytes+{-# INLINE sendMessage #-} + +flushClient :: ClientHandle -> IO () +flushClient (ClientHandle (_,h,_)) = hFlush h++
− src/Nettle/Servers/MessengerServer.hs
@@ -1,116 +0,0 @@-{-# 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 ()
src/Nettle/Servers/MultiplexedTCPServer.hs view
@@ -9,56 +9,61 @@ module Nettle.Servers.MultiplexedTCPServer ( muxedTCPServer, - MultiplexedProcess,- TCPMessage(..)+ TCPMessage(..), + ServerPortNumber+ ) where import Prelude hiding (interact, catch)-import Nettle.Servers.TwoWayChannel -import Nettle.Servers.TCPServer+import Network.Socket (SockAddr)+import Nettle.OpenFlow.Messages 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+import Nettle.Servers.Server -- | 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.+ | ConnectionTerminated SockAddr -- ^ 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))+ +instance Functor TCPMessage where+ fmap f (ConnectionEstablished a) = ConnectionEstablished a+ fmap f (ConnectionTerminated a) = ConnectionTerminated a + fmap f (PeerMessage a x) = PeerMessage a (f x) - 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 +-- | Runs a server that returns two commands, one to receive the next message from any connected client, +-- and one that sends a message to a client. +muxedTCPServer :: ServerPortNumber+ -> IO (IO (TCPMessage (TransactionID,SCMessage)), + SockAddr -> (TransactionID,CSMessage) -> IO ())+muxedTCPServer pstring = do+ server <- startOpenFlowServer Nothing pstring+ addressToClientMap <- newMVar Map.empty+ incomingChan <- newChan + let enqIncoming clientHandle =+ do mm <- receiveFromSwitch clientHandle+ case mm of + Nothing -> do modifyMVar_ addressToClientMap (return . Map.delete (switchSockAddr clientHandle))+ writeChan incomingChan (ConnectionTerminated (switchSockAddr clientHandle))+ return ()+ Just m -> do writeChan incomingChan (PeerMessage (switchSockAddr clientHandle) m) + enqIncoming clientHandle+ let getIncoming = readChan incomingChan+ let postOutgoing sockAddress msg = + withMVar addressToClientMap $ \dict -> + case Map.lookup sockAddress dict of+ Just switchHandle -> sendToSwitch switchHandle msg+ Nothing -> error ("handle disappeared before message " ++ show msg ++ " was sent.")+ let acceptLoop = + forever (do (client,_) <- acceptSwitch server+ modifyMVar_ addressToClientMap (return . Map.insert (switchSockAddr client) client)+ writeChan incomingChan (ConnectionEstablished (switchSockAddr client))+ forkIO (enqIncoming client)+ )+ + forkIO acceptLoop + return (getIncoming, postOutgoing)
+ src/Nettle/Servers/Server.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | Provides a simple, basic, and efficient server which provides methods+-- to listen for new switches to connect, and to receive and send OpenFlow+-- messages to switches. This server handles the initialization procedure with switches+-- and handles echo requests from switches.+module Nettle.Servers.Server+ ( + -- * OpenFlow Server+ OpenFlowServer+ , ServerPortNumber + , HostName+ , startOpenFlowServer+ , acceptSwitch + , closeServer+ -- * Switch connection+ , SwitchHandle+ , handle2SwitchID+ , switchSockAddr+ , receiveFromSwitch+ , receiveBatch+ , sendToSwitch+ , sendBatch+ , sendBatches+ , sendToSwitchWithID+ , closeSwitchHandle+ -- * Utility+ , untilNothing+ ) where+++import Control.Exception+import Network.Socket hiding (recv)+import Network.Socket.ByteString (recv, sendAll, sendMany)+import qualified Data.ByteString as S+import System.IO+import Data.Binary.Strict.Get+import Nettle.OpenFlow+import qualified Nettle.OpenFlow.StrictPut as Strict+import Data.Word+import Foreign+import qualified Data.ByteString.Internal as S+import Data.Map (Map)+import qualified Data.Map as Map+import Text.Printf+++type ServerPortNumber = Word16+deriving instance Ord SockAddr++-- | Abstract type containing the state of the OpenFlow server.+newtype OpenFlowServer = OpenFlowServer (Socket, IORef (Map SwitchID SwitchHandle))++-- | Starts an OpenFlow server. +-- The server socket will be bound to a wildcard IP address if the first argument is 'Nothing' and will be bound to a particular +-- address if the first argument is 'Just' something. The 'HostName' value can either be an IP address in dotted quad notation, +-- like 10.1.30.127, or a host name, whose IP address will be looked up. The server port must be specified.+startOpenFlowServer :: Maybe HostName -> ServerPortNumber -> IO OpenFlowServer+startOpenFlowServer mHostName portNumber = + do addrinfos <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]})) mHostName (Just $ show portNumber)+ let serveraddr = head addrinfos+ sock <- socket (addrFamily serveraddr) Stream defaultProtocol+ setSocketOption sock ReuseAddr 1+ -- setSocketOption sock RecvBuffer (2^7 * 2^10)+ -- setSocketOption sock SendBuffer (2^7 * 2^10)+ bindSocket sock (addrAddress serveraddr)+ listen sock queueLength+ switchHandleMapRef <- newIORef Map.empty+ return (OpenFlowServer (sock, switchHandleMapRef))+ where + queueLength = maxListenQueue++-- | Closes the OpenFlow server.+closeServer :: OpenFlowServer -> IO ()+closeServer (OpenFlowServer (s,_)) = sClose s+++-- | Abstract type managing the state of the switch connection.+data SwitchHandle = SwitchHandle !(SockAddr, Socket, ForeignPtr Word8, IORef S.ByteString, SwitchID, OpenFlowServer)++-- | Blocks until a switch connects to the server and returns the +-- switch handle.+acceptSwitch :: OpenFlowServer -> IO (SwitchHandle, SwitchFeatures)+acceptSwitch ofps@(OpenFlowServer (s,shmr)) = + do (connsock, clientaddr) <- accept s+ let bufferSize = 1024 * 1024+ outBufferPtr <- mallocForeignPtrBytes bufferSize :: IO (ForeignPtr Word8)+ inBufferRef <- newIORef S.empty+ let sh = SwitchHandle (clientaddr, connsock, outBufferPtr, inBufferRef, -1, ofps)+ (sid, sfr) <- handshake sh+ return (SwitchHandle (clientaddr, connsock, outBufferPtr, inBufferRef, sid, ofps), sfr)+ where + handshake switch + = do sendToSwitch switch (0, CSHello)+ m <- receiveFromSwitch switch+ case m of + Nothing -> error ("switch broke connection")+ Just (xid, msg) -> + case msg of + SCHello -> go2 switch+ _ -> error ("received unexpected message during handshake: " ++ show (xid, msg))+ go2 switch = go2'+ where go2' = do sendToSwitch switch (0, FeaturesRequest)+ m <- receiveFromSwitch switch+ case m of + Nothing -> error "switch broke connection during handshake"+ Just (xid, msg) -> + case msg of + Features (sfr@(SwitchFeatures { switchID })) ->+ do switchHandleMap <- readIORef shmr+ writeIORef shmr (Map.insert switchID switch switchHandleMap)+ return (switchID, sfr)+ SCEchoRequest bytes -> + do sendToSwitch switch (xid, CSEchoReply bytes) + go2'+ _ -> + do putStrLn ("ignoring non feature message while waiting for features: " ++ show (xid, msg))+ go2'+ + ++-- | Returns the socket address of the switch connection. +switchSockAddr :: SwitchHandle -> SockAddr+switchSockAddr (SwitchHandle (a,_,_,_,_,_)) = a++receiveBatch :: SwitchHandle -> IO [(TransactionID, SCMessage)]+receiveBatch sh@(SwitchHandle (_, s, _, inBufferRef,_,_)) = + do newBatchBS <- recv s batchSize+ inBuffer <- readIORef inBufferRef+ let batchBS = S.append inBuffer newBatchBS+ (chunks, remaining) <- splitChunks sh batchBS+ writeIORef inBufferRef remaining+ return chunks+ where + batchSize = 1 * 2^10+{-# INLINE receiveBatch #-}++splitChunks :: SwitchHandle -> S.ByteString -> IO ([(TransactionID, SCMessage)], S.ByteString)+splitChunks sh buffer = go buffer []+ where + go buffer chunks =+ if S.length buffer < headerSize+ then return ({-# SCC "splitChunks1" #-} reverse chunks, buffer)+ else + let (result, buffer') = {-# SCC "splitChunks2" #-} runGet getHeader buffer+ in case result of+ Left err -> error err+ Right header -> + let expectedBodyLen = fromIntegral (msgLength header) - headerSize+ in if expectedBodyLen <= S.length buffer'+ then let (result', buffer'') = {-# SCC "splitChunks3" #-} runGet (getSCMessageBody header) buffer'+ in case result' of + Left err -> error err+ Right msg -> + case msg of + (xid, SCEchoRequest bytes) -> do sendToSwitch sh (xid, CSEchoReply bytes) + go buffer'' chunks+ _ -> go buffer'' (msg : chunks)+ else return ({-# SCC "splitChunks4" #-} reverse chunks, buffer)+ where headerSize = 8 + + +-- | Blocks until a message is received from the switch or the connection is closed.+-- Returns `Nothing` only if the connection is closed.+receiveFromSwitch :: SwitchHandle -> IO (Maybe (TransactionID, SCMessage))+receiveFromSwitch sh@(SwitchHandle (clientAddr, s, _, _, _, _)) + = do hdrbs <- recv s headerSize + if (headerSize /= S.length hdrbs) + then if S.length hdrbs == 0 + then return Nothing + else error "error reading header"+ else + case fst (runGet getHeader hdrbs) of+ Left err -> error err+ Right header -> + do let expectedBodyLen = fromIntegral (msgLength header) - headerSize+ bodybs <- if expectedBodyLen > 0 + then do bodybs <- recv s expectedBodyLen + when (expectedBodyLen /= S.length bodybs) (error "error reading body")+ return bodybs+ else return S.empty+ case fst (runGet (getSCMessageBody header) bodybs ) of+ Left err -> error err+ Right msg -> + case msg of + (xid, SCEchoRequest bytes) -> do sendToSwitch sh (xid, CSEchoReply bytes)+ receiveFromSwitch sh+ _ -> return (Just msg)+ where headerSize = 8 +{-# INLINE receiveFromSwitch #-}++-- | Send a message to the switch.+sendToSwitch :: SwitchHandle -> (TransactionID, CSMessage) -> IO () +sendToSwitch (SwitchHandle (_,s,fptr,_,_, _)) msg =+ do bytes <- withForeignPtr fptr $ \ptr -> Strict.runPut ptr (putCSMessage msg) + let bs = S.fromForeignPtr fptr 0 bytes+ sendAll s bs+{-# INLINE sendToSwitch #-} + +sendBatch :: SwitchHandle -> Int -> [(TransactionID, CSMessage)] -> IO () +sendBatch (SwitchHandle(_, s, _, _,_, _)) maxSize batch = + sendMany s $ map (\msg -> Strict.runPutToByteString maxSize (putCSMessage msg)) batch+{-# INLINE sendBatch #-}+ +sendBatches :: SwitchHandle -> Int -> [[(TransactionID, CSMessage)]] -> IO () +sendBatches (SwitchHandle(_, s, fptr, _,_, _)) maxSize batches = + do bytes <- withForeignPtr fptr $ \ptr -> {-# SCC "sendBatches1" #-} Strict.runPut ptr ({-# SCC "sendBatches1a" #-} mapM_ (mapM_ putCSMessage) batches)+ let bs = S.fromForeignPtr fptr 0 bytes+ {-# SCC "sendBatches2" #-} sendAll s bs+{-# INLINE sendBatches #-}+ + {- This is slower than the above.+ mapM_ f batches+ where f batch = do bytes <- withForeignPtr fptr $ \ptr -> Strict.runPut ptr (mapM_ putCSMessage batch)+ let bs = S.fromForeignPtr fptr 0 bytes+ sendAll s bs+ -} + + +sendToSwitchWithID :: OpenFlowServer -> SwitchID -> (TransactionID, CSMessage) -> IO () +sendToSwitchWithID (OpenFlowServer (_,shmr)) sid msg + = do switchHandleMap <- readIORef shmr + case Map.lookup sid switchHandleMap of+ Nothing -> printf "Tried to send message to switch: %d, but it is no longer connected.\nMessage was %s.\n" sid (show msg)+ Just sh -> sendToSwitch sh msg --this could fail.+{-# INLINE sendToSwitchWithID #-} + +-- | Close a switch connection. +closeSwitchHandle :: SwitchHandle -> IO () +closeSwitchHandle (SwitchHandle (_, s,_,_,sid, OpenFlowServer (_, shmr))) = + do switchHandleMap <- readIORef shmr+ writeIORef shmr (Map.delete sid switchHandleMap) + sClose s++handle2SwitchID :: SwitchHandle -> SwitchID+handle2SwitchID (SwitchHandle (_, _, _, _, sid, _)) = sid+{-# INLINE handle2SwitchID #-} ++-- | Repeatedly perform the first action, passing its result to the second action, until+-- the result of the first action is 'Nothing', at which point the computation returns.+untilNothing :: IO (Maybe a) -> (a -> IO ()) -> IO ()+untilNothing sense act = go+ where go = do ma <- sense+ case ma of+ Nothing -> return ()+ Just a -> act a >> go+
− src/Nettle/Servers/TCPServer.hs
@@ -1,113 +0,0 @@-{-# 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) - - --
− src/Nettle/Servers/TwoWayChannel.hs
@@ -1,56 +0,0 @@-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 ()-
+ src/Nettle/Topology/ExtendedDouble.hs view
@@ -0,0 +1,20 @@+module Nettle.Topology.ExtendedDouble (+ ExtendedDouble(..)+ , addExtendedDouble+ ) where++data ExtendedDouble = Finite !Double + | Infinity + deriving (Show,Read,Eq)+ +addExtendedDouble :: ExtendedDouble -> ExtendedDouble -> ExtendedDouble+addExtendedDouble (Finite x) (Finite y) = Finite (x + y)+addExtendedDouble _ _ = Infinity+ +instance Ord ExtendedDouble where + Finite x <= Finite y = x <= y+ Finite _ <= Infinity = True+ Infinity <= Infinity = True+ Infinity <= Finite _ = False++
+ src/Nettle/Topology/FloydWarshall.hs view
@@ -0,0 +1,105 @@+-- | Implements the Floyd-Warshall algorithm for computing all-pairs shortest paths +-- from a weighted directed graph. +module Nettle.Topology.FloydWarshall (+ floydWarshall+ , shortestPath+ ) where++import Data.Array.MArray+import Data.Array.IArray+import Data.Array.ST+import Control.Monad+import Data.Map (Map)+import qualified Data.Map as Map+import Nettle.Topology.ExtendedDouble+++-- | The input is a matrix where the @(i,j)@ entry contains the distance of a path+-- going from node @i@ to node @j@ in the graph as well as the next hop node in the path and a value+-- (left polymorphic, of type @a@ here) representing the link (e.g. a link identifier, particularly useful if there can+-- more than one link between nodes). If the distance is |Infinity| then the next hop and link identifier should be |Nothing|. +-- Typically, this function is applied to an array in which @(i,j)@ value contains the distance and the link ID for one link from+-- @i@ to @j@.+floydWarshall :: Array (Int,Int) (ExtendedDouble, Maybe (Int, a)) -> Array (Int,Int) (ExtendedDouble, Maybe (Int, a))+floydWarshall input = + runSTArray $+ do d <- thaw input + forM [1..n] $ \k ->+ forM [1..n] $ \i -> + forM [1..n] $ \j -> + do (dij, predij) <- readArray d (i,j)+ (dik, predik) <- readArray d (i,k)+ (dkj, predkj) <- readArray d (k,j)+ let dikj = dik `addExtendedDouble` dkj+ when (dikj < dij) (writeArray d (i,j) (dikj, predkj))+ return d+ where (_, (n,_)) = bounds input++-- | Extracts the shortest path from the matrix computed by |floydWarshall|. The path includes the+-- the nodes and the links of the path.+shortestPath :: Array (Int, Int) (ExtendedDouble, Maybe (Int, a)) -> (Int, Int) -> Maybe [(Int,a)]+shortestPath dp (start, end) = + let (_, mprev) = dp ! (start, end)+ in case mprev of + Nothing -> if start == end then Just [] else Nothing+ Just (prev,a) -> aux start prev [(end,a)]+ where aux start end acc + | start == end = Just acc+ | otherwise = + let (_,mprev) = dp ! (start,end) + in case mprev of + Nothing -> Nothing+ Just (prev,a) -> aux start prev ((end,a) : acc)+++path :: Array (Int, Int) (ExtendedDouble, Maybe Int) -> (Int, Int) -> Maybe [Int]+path dp (start, end) = + let (_, mprev) = dp ! (start, end)+ in case mprev of + Nothing -> Nothing+ Just prev -> aux start prev [end]+ where aux start end acc + | start == end = Just acc+ | otherwise = + let (_,mprev) = dp ! (start,end) + in case mprev of + Nothing -> Nothing+ Just prev -> aux start prev (end : acc)++pathMap :: Array (Int, Int) (ExtendedDouble, Maybe Int) -> Map (Int,Int) [Int]+pathMap dp + = Map.fromList $ [ (k, p) | (k,_) <- assocs dp, Just p <- [path dp k] ]++++{-+fw :: Int -> [ExtendedDouble] -> Array (Int,Int) ExtendedDouble+fw n dists = + runSTArray $+ do d <- newListArray ((1,1), (n,n)) dists+ forM [1..n] $ \k ->+ forM [1..n] $ \i -> + forM [1..n] $ \j -> + do dij <- readArray d (i,j)+ dik <- readArray d (i,k)+ dkj <- readArray d (k,j)+ writeArray d (i,j) (min dij (dik `addExtendedDouble` dkj))+ return d+ + +-- Assumes a graph on n nodes.+-- The input is a list of hop weights and predecessor values in order of (1,1), (1,2),...(1,n),(2,1),...(n,n).+fw2 :: Int -> [(ExtendedDouble, Maybe Int)] -> Array (Int,Int) (ExtendedDouble, Maybe Int)+fw2 n dists = + runSTArray $+ do d <- newListArray ((1,1), (n,n)) dists+ forM [1..n] $ \k ->+ forM [1..n] $ \i -> + forM [1..n] $ \j -> + do (dij, predij) <- readArray d (i,j)+ (dik, predik) <- readArray d (i,k)+ (dkj, predkj) <- readArray d (k,j)+ let dikj = dik `addExtendedDouble` dkj+ when (dikj < dij) (writeArray d (i,j) (dikj, predkj))+ return d+-}
+ src/Nettle/Topology/LabelledGraph.hs view
@@ -0,0 +1,154 @@+-- | This module implements a data type of directed graphs+-- where there may be multiple edges between a pair of vertices.+-- There are a variety of ways to think of this: +-- As two finite sets @V@, @E@ with two maps source, target : @E -> V@.+-- As a finite Set @V@, a finite set of labels @L@, and a ternary relation as a subset of @(V,L,V)@. +module Nettle.Topology.LabelledGraph (+ LabelledGraph (sourceTarget)+ , Weight+ -- * Construction+ , empty+ , addNode+ , addEdge+ , adjustEdgeWeight+ , deleteNode+ , deleteEdge+ -- * Query+ , nodes+ , numberOfNodes+ , edgesOutOf+ , edgesFromTo+ , edges+ -- * Path tree+ , LTree(..)+ , pathTree+ , mapLTree+ , drawTree+ ) where++import Data.List (minimumBy)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map, (!))+import qualified Data.Map as Map+import Nettle.Topology.ExtendedDouble+import Data.Maybe++data LabelledGraph n e = + LabelledGraph { sourceTarget :: Map e ((n, n), Weight)+ , edgesLeaving :: Map n (Map e (n, Weight))+ }+ deriving (Show)+ ++type Weight = Double++nodes :: Ord n => LabelledGraph n e -> [n]+nodes lg = Map.keys $ edgesLeaving lg ++numberOfNodes :: Ord n => LabelledGraph n e -> Int+numberOfNodes lg = Map.size (edgesLeaving lg)++weightOf :: Ord e => e -> LabelledGraph n e -> Weight+weightOf e lg = snd $ sourceTarget lg ! e++source :: (Ord n, Ord e) => LabelledGraph n e -> e -> n+source g e = fst (fst (sourceTarget g ! e))++edges :: LabelledGraph n e -> [(e, Weight)]+edges (LabelledGraph { sourceTarget = sourceTarget }) = Map.assocs $ Map.map snd sourceTarget++shortestEdgeFromTo :: (Ord e, Ord n) => n -> n -> LabelledGraph n e -> Maybe (e,Weight)+shortestEdgeFromTo s t g + = case edgesFromTo s t g of+ [] -> Nothing+ (e:es) -> Just (minimumBy (\e1 e2 -> compare (snd e1) (snd e2)) (e:es))++edgesFromTo :: (Ord e, Ord n) => n -> n -> LabelledGraph n e -> [(e,Weight)]+edgesFromTo u v (LabelledGraph { sourceTarget = sourceTarget })+ = Map.toList $ Map.map snd $ Map.filter (\((u',v'),_) -> u == u' && v == v') sourceTarget++edgesOutOf :: (Ord e, Ord n) => n -> LabelledGraph n e -> [(e, n)]+edgesOutOf u lg =+ map (\(e, (t,w)) -> (e,t)) (Map.assocs (edgesLeaving lg ! u))++empty :: (Ord n, Ord e) => LabelledGraph n e+empty = LabelledGraph { sourceTarget = Map.empty+ , edgesLeaving = Map.empty+ }+++addNode :: Ord n => n -> LabelledGraph n e -> LabelledGraph n e+addNode n topology@(LabelledGraph { edgesLeaving = edgesLeaving' }) + = topology { edgesLeaving = Map.insert n Map.empty edgesLeaving' + }+++addEdge :: (Ord n, Ord e) => e -> (n,n) -> Weight -> LabelledGraph n e -> LabelledGraph n e +addEdge e st weight topology@(LabelledGraph { sourceTarget = sourceTarget', edgesLeaving = edgesLeaving' })+ = let el = Map.unionWith Map.union edgesLeaving' (Map.fromList [(fst st, Map.singleton e (snd st, weight)), (snd st, Map.empty)])+ in topology { sourceTarget = Map.insert e (st, weight) sourceTarget' + , edgesLeaving = el+ }+ ++adjustEdgeWeight :: (Ord n, Ord e) => e -> (Weight -> Weight) -> LabelledGraph n e -> LabelledGraph n e+adjustEdgeWeight e f graph + = let el = Map.adjust (Map.adjust (\(st,weight) -> (st, f weight)) e) (source graph e) (edgesLeaving graph)+ in graph { sourceTarget = Map.adjust (\(st,weight) -> (st, f weight)) e (sourceTarget graph) + , edgesLeaving = el+ }+++deleteNode :: (Ord e, Ord n) => n -> LabelledGraph n e -> LabelledGraph n e+deleteNode n topo@(LabelledGraph { sourceTarget = sourceTarget', edgesLeaving = edgesLeaving' }) + = LabelledGraph { sourceTarget = Map.filter p sourceTarget'+ , edgesLeaving = Map.delete n edgesLeaving'+ }+ where p ((s,t),_) = s /= n && t /= n+ ++deleteEdge :: (Ord n, Ord e) => e -> LabelledGraph n e -> LabelledGraph n e +deleteEdge e topology@(LabelledGraph { sourceTarget = sourceTarget', edgesLeaving = edgesLeaving' }) + = let el = Map.adjust (Map.delete e) (source topology e) edgesLeaving'+ in topology { edgesLeaving = el } + + +data LTree a b = LNode a [(b, LTree a b)]+ deriving (Show, Eq)++mapLTree :: (a -> c) -> (b -> d) -> LTree a b -> LTree c d+mapLTree f g (LNode a bts) = LNode (f a) [ (g b, mapLTree f g t) | (b, t) <- bts ]++-- | Computes the path tree from one node to another node of the graph. +-- Each node of the tree is a path in the graph from the source to some node in the graph. +-- The parent of a node is the node representing the path with one less edge than the node.+pathTree :: (Ord n, Ord e) => LabelledGraph n e -> n -> n -> Maybe (LTree n (e, Weight))+pathTree g s d + = search g s []+ where + search g u visited + | u == d = Just (LNode u [])+ | u /= d = let ets = [ ((e,weightOf e g),t) + | (e,tgt) <- edgesOutOf u g+ , not (tgt `elem` visited)+ , Just t <- [search (deleteNode u g) tgt (u:visited)] + ]+ in if null ets+ then Nothing+ else Just (LNode u ets)++-- | Neat 2-dimensional drawing of a tree. Mostly borrowed from code in @Data.Tree@ module. +drawTree :: LTree String String -> String+drawTree = unlines . draw++draw :: LTree String String -> [String]+draw (LNode x ts0) = x : drawSubTrees ts0+ where+ drawSubTrees [] = []+ drawSubTrees [(l,t)] =+ "|" : shift ("`" ++ l ++ "- ") " " (draw t)+ drawSubTrees ((l,t):ts) =+ "|" : shift ("+" ++ l ++ "- ") "| " (draw t) ++ drawSubTrees ts++ shift first other = zipWith (++) (first : repeat other)
+ src/Nettle/Topology/Topology.hs view
@@ -0,0 +1,151 @@+-- | This module implements a data structure that can be+-- used to maintain information about the topology of an OpenFlow +-- network. It maintains a graph whose nodes are switches and whose edges are links connect+-- switches and attaching to switches at particular ports.+module Nettle.Topology.Topology (+ LinkID+ , Topology+ , Weight+ -- * Construction+ , empty+ , addLink+ , adjustLinkWeight+ , deleteLink+ , addSwitch+ , deleteSwitch+ , addEdgePort+ , addEdgePorts+ -- * Query+ , lookupLink+ , links+ , lGraph+ , edgePorts+ -- * Shortest paths+ , ShortestPathMatrix+ , shortestPathMatrix+ , pathBetween+ -- * Utilities to create topologies+ , completeTopology+ , makeTopology+ ) where++import Nettle.Topology.LabelledGraph hiding (empty)+import qualified Nettle.Topology.LabelledGraph as LG+import Nettle.Topology.FloydWarshall+import Nettle.Topology.ExtendedDouble+import Data.Array.IArray hiding ((!))+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Map as Map+import Data.Map (Map, (!))+import Data.List (minimumBy, sort)+import Nettle.OpenFlow++type LinkID = ((SwitchID,PortID), (SwitchID, PortID))++data Topology = Topology { lGraph :: LabelledGraph SwitchID LinkID + , edgePorts :: Set (SwitchID, PortID) + }++links :: Topology -> [LinkID]+links topo = map fst $ edges $ lGraph topo++data ShortestPathMatrix = + ShortestPathMatrix { matrix :: Array (Int, Int) (ExtendedDouble, Maybe (Int, LinkID))+ , num2switch :: Map Int SwitchID+ , switch2num :: Map SwitchID Int+ } ++shortestPathMatrix :: Topology -> ShortestPathMatrix+shortestPathMatrix topology = + ShortestPathMatrix { matrix = floydWarshall (array ((1,1), (r,r)) assocs)+ , num2switch = Map.fromList numberedNodes+ , switch2num = Map.fromList (map twist numberedNodes)}+ where r = numberOfNodes $ lGraph topology+ assocs = [ ((m,n),+ if m==n + then (Finite 0, Nothing) + else case edgesFromTo u v (lGraph topology) of + [] -> (Infinity, Nothing)+ links -> let (l,w) = minimumBy (\x y -> compare (snd x) (snd y)) links + in (Finite w, Just (m, l)) + )+ | (m,u) <- numberedNodes, (n,v) <- numberedNodes+ ]+ numberedNodes = zip [1..] (nodes (lGraph topology))+ twist (a,b) = (b,a)+ +pathBetween :: ShortestPathMatrix -> SwitchID -> SwitchID -> Maybe [LinkID]+pathBetween spm source dest + = fmap (map (\(n,link) -> link)) $+ shortestPath (matrix spm) (switch2num spm ! source, switch2num spm ! dest)+ +lookupLink :: Topology -> SwitchID -> PortID -> (LinkID, Weight)+lookupLink topo sid pid + = let [lw] = filter p (edges $ lGraph topo)+ in lw+ where p (((x,y),(z,u)), _) = (x==sid && y==pid) || (z==sid && u==pid)++adjustLinkWeight :: LinkID -> (Weight -> Weight) -> Topology -> Topology+adjustLinkWeight linkid f topo+ = topo { lGraph = adjustEdgeWeight linkid f (lGraph topo) }++-- ensure invariant that no two links have same (switch,port) pairs.+addLink :: LinkID -> Weight -> Topology -> Topology+addLink e@((u,p),(v,q)) w topo+ = topo { lGraph = addEdge e (u,v) w (lGraph topo) }++deleteLink :: LinkID -> Topology -> Topology+deleteLink lid topo + = topo { lGraph = deleteEdge lid (lGraph topo ) }++addSwitch :: SwitchID -> Topology -> Topology+addSwitch sid topo+ = topo { lGraph = addNode sid (lGraph topo) }++deleteSwitch :: SwitchID -> Topology -> Topology+deleteSwitch sid topo + = topo { lGraph = deleteNode sid (lGraph topo) }++empty :: Topology+empty = Topology { lGraph = LG.empty, edgePorts = Set.empty }++addEdgePort :: SwitchID -> PortID -> Topology -> Topology +addEdgePort sid pid topo + = topo { edgePorts = Set.insert (sid,pid) (edgePorts topo) }++addEdgePorts :: [(SwitchID, PortID)] -> Topology -> Topology+addEdgePorts sps topo + = topo { edgePorts = foldr Set.insert (edgePorts topo) sps } ++-- builds complete graph of n switches with the high ports (ports numbered n+1 or higher) are edge ports, with one directed edge per pair of switches.+completeTopology :: Int -> Int -> Weight -> Topology+completeTopology n portsPerSwitch weight+ = foldr f topo0 links + where links = concat [ [ ((s, d-1), (d,s)), ((d,s),(s,d-1)) ] | s <- [1..n], d <- [s+1..n]]+ eps = [ (fromIntegral s, fromIntegral p) | s <- [1..n], p <- [n..portsPerSwitch]]+ f ((x,y),(z,u)) = addLink ((fromIntegral x, fromIntegral y), (fromIntegral z, fromIntegral u)) weight+ topo0 = addEdgePorts eps empty+ +makeTopology :: Int -> Int -> [(Int,Int,Weight)] -> Topology+makeTopology n numEdgePorts edges + = foldr f topo0 links+ where topo0 = addEdgePorts eps empty + eps = [ (fromIntegral s, fromIntegral (nextPort + p)) + | s <- [1..n], + let nextPort = dict ! s, + p <- [0..(numEdgePorts-1)] + ]+ f ((x,y),(z,u),weight) = addLink ((fromIntegral x, fromIntegral y), + (fromIntegral z, fromIntegral u)) weight+ (dict, links) = + foldl step base (sort edges)+ where step (dict,edges) (u,v,weight) =+ let pu = dict ! u+ pv = dict ! v+ dict' = Map.adjust (+1) u (Map.adjust (+1) v dict)+ edges' = ((u,pu),(v,pv),weight) : ((v,pv),(u,pu),weight) : edges+ in (dict', edges')+ base = (dict0, edges0) + dict0 = Map.fromList [(u,1) | u <- [1..n]]+ edges0 = []