diff --git a/nettle-openflow.cabal b/nettle-openflow.cabal --- a/nettle-openflow.cabal +++ b/nettle-openflow.cabal @@ -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 () 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 + + diff --git a/src/Examples/Flood.hs b/src/Examples/Flood.hs new file mode 100644 --- /dev/null +++ b/src/Examples/Flood.hs @@ -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 () + diff --git a/src/Examples/Hub.hs b/src/Examples/Hub.hs new file mode 100644 --- /dev/null +++ b/src/Examples/Hub.hs @@ -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 () + diff --git a/src/Examples/SimpleImperativeIONetworkControl/NetLearningSwitch.hs b/src/Examples/SimpleImperativeIONetworkControl/NetLearningSwitch.hs deleted file mode 100644 --- a/src/Examples/SimpleImperativeIONetworkControl/NetLearningSwitch.hs +++ /dev/null @@ -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) - - - - - diff --git a/src/Examples/SimpleImperativeIONetworkControl/SimpleImperativeIONetworkControl.hs b/src/Examples/SimpleImperativeIONetworkControl/SimpleImperativeIONetworkControl.hs deleted file mode 100644 --- a/src/Examples/SimpleImperativeIONetworkControl/SimpleImperativeIONetworkControl.hs +++ /dev/null @@ -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)) - diff --git a/src/Nettle/Ethernet/AddressResolutionProtocol.hs b/src/Nettle/Ethernet/AddressResolutionProtocol.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/Ethernet/AddressResolutionProtocol.hs @@ -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 + diff --git a/src/Nettle/Ethernet/EthernetAddress.hs b/src/Nettle/Ethernet/EthernetAddress.hs --- a/src/Nettle/Ethernet/EthernetAddress.hs +++ b/src/Nettle/Ethernet/EthernetAddress.hs @@ -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 diff --git a/src/Nettle/Ethernet/EthernetFrame.hs b/src/Nettle/Ethernet/EthernetFrame.hs --- a/src/Nettle/Ethernet/EthernetFrame.hs +++ b/src/Nettle/Ethernet/EthernetFrame.hs @@ -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 diff --git a/src/Nettle/IPv4/IPAddress.hs b/src/Nettle/IPv4/IPAddress.hs --- a/src/Nettle/IPv4/IPAddress.hs +++ b/src/Nettle/IPv4/IPAddress.hs @@ -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 diff --git a/src/Nettle/IPv4/IPPacket.hs b/src/Nettle/IPv4/IPPacket.hs --- a/src/Nettle/IPv4/IPPacket.hs +++ b/src/Nettle/IPv4/IPPacket.hs @@ -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) diff --git a/src/Nettle/OpenFlow.hs b/src/Nettle/OpenFlow.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/OpenFlow.hs @@ -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 diff --git a/src/Nettle/OpenFlow/Action.hs b/src/Nettle/OpenFlow/Action.hs --- a/src/Nettle/OpenFlow/Action.hs +++ b/src/Nettle/OpenFlow/Action.hs @@ -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@. diff --git a/src/Nettle/OpenFlow/FlowTable.hs b/src/Nettle/OpenFlow/FlowTable.hs --- a/src/Nettle/OpenFlow/FlowTable.hs +++ b/src/Nettle/OpenFlow/FlowTable.hs @@ -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) diff --git a/src/Nettle/OpenFlow/Match.hs b/src/Nettle/OpenFlow/Match.hs --- a/src/Nettle/OpenFlow/Match.hs +++ b/src/Nettle/OpenFlow/Match.hs @@ -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 diff --git a/src/Nettle/OpenFlow/Messages.hs b/src/Nettle/OpenFlow/Messages.hs --- a/src/Nettle/OpenFlow/Messages.hs +++ b/src/Nettle/OpenFlow/Messages.hs @@ -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) diff --git a/src/Nettle/OpenFlow/MessagesBinary.hs b/src/Nettle/OpenFlow/MessagesBinary.hs --- a/src/Nettle/OpenFlow/MessagesBinary.hs +++ b/src/Nettle/OpenFlow/MessagesBinary.hs @@ -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 + ----------------------------------- diff --git a/src/Nettle/OpenFlow/Packet.hs b/src/Nettle/OpenFlow/Packet.hs --- a/src/Nettle/OpenFlow/Packet.hs +++ b/src/Nettle/OpenFlow/Packet.hs @@ -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 diff --git a/src/Nettle/OpenFlow/Port.hs b/src/Nettle/OpenFlow/Port.hs --- a/src/Nettle/OpenFlow/Port.hs +++ b/src/Nettle/OpenFlow/Port.hs @@ -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) diff --git a/src/Nettle/OpenFlow/StrictPut.hs b/src/Nettle/OpenFlow/StrictPut.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/OpenFlow/StrictPut.hs @@ -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 diff --git a/src/Nettle/OpenFlow/Switch.hs b/src/Nettle/OpenFlow/Switch.hs --- a/src/Nettle/OpenFlow/Switch.hs +++ b/src/Nettle/OpenFlow/Switch.hs @@ -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) diff --git a/src/Nettle/Servers/Client.hs b/src/Nettle/Servers/Client.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/Servers/Client.hs @@ -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 + + diff --git a/src/Nettle/Servers/MessengerServer.hs b/src/Nettle/Servers/MessengerServer.hs deleted file mode 100644 --- a/src/Nettle/Servers/MessengerServer.hs +++ /dev/null @@ -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 () diff --git a/src/Nettle/Servers/MultiplexedTCPServer.hs b/src/Nettle/Servers/MultiplexedTCPServer.hs --- a/src/Nettle/Servers/MultiplexedTCPServer.hs +++ b/src/Nettle/Servers/MultiplexedTCPServer.hs @@ -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) diff --git a/src/Nettle/Servers/Server.hs b/src/Nettle/Servers/Server.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/Servers/Server.hs @@ -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 + diff --git a/src/Nettle/Servers/TCPServer.hs b/src/Nettle/Servers/TCPServer.hs deleted file mode 100644 --- a/src/Nettle/Servers/TCPServer.hs +++ /dev/null @@ -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) - - - - diff --git a/src/Nettle/Servers/TwoWayChannel.hs b/src/Nettle/Servers/TwoWayChannel.hs deleted file mode 100644 --- a/src/Nettle/Servers/TwoWayChannel.hs +++ /dev/null @@ -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 () - diff --git a/src/Nettle/Topology/ExtendedDouble.hs b/src/Nettle/Topology/ExtendedDouble.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/Topology/ExtendedDouble.hs @@ -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 + + diff --git a/src/Nettle/Topology/FloydWarshall.hs b/src/Nettle/Topology/FloydWarshall.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/Topology/FloydWarshall.hs @@ -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 +-} diff --git a/src/Nettle/Topology/LabelledGraph.hs b/src/Nettle/Topology/LabelledGraph.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/Topology/LabelledGraph.hs @@ -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) diff --git a/src/Nettle/Topology/Topology.hs b/src/Nettle/Topology/Topology.hs new file mode 100644 --- /dev/null +++ b/src/Nettle/Topology/Topology.hs @@ -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 = []