diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2011, 2012, Cornell University, Princeton University +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the copyright holders nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/netcore.cabal b/netcore.cabal new file mode 100644 --- /dev/null +++ b/netcore.cabal @@ -0,0 +1,171 @@ +Name: netcore +Version: 1.0.0 +Copyright: (c) 2011--2012, Cornell University and Princeton University +License: BSD3 +License-File: LICENSE +Cabal-Version: >= 1.9.2 +Build-Type: Simple +Maintainer: Arjun Guha , + Cole Schlesinger , + Alec Story +Stability: experimental +Homepage: http://frenetic-lang.org +Bug-reports: http://github.com/frenetic-lang/netcore/issues +Tested-with: GHC==7.4.1 +Category: Network +Synopsis: The NetCore compiler and runtime system for OpenFlow networks. +Description: + NetCore is a high-level network programming language. This package provides + a NetCore compiler and runtime system for OpenFlow networks. + + See the 'Frenetic.NetCore' module for commonly used functions. + + We have several example programs available online at + + +Source-repository head + type: git + location: git://github.com/frenetic-lang/netcore.git + +Source-repository this + type: git + location: git://github.com/frenetic-lang/netcore.git + tag: 1.0.0 + +Library + build-depends: + base >= 4 && < 5, + containers >= 0.4.2.1, + multiset >= 0.2.1, + mtl >= 2.0.1.0, + ansi-wl-pprint, + fgl, + process, + random, + HList, + hslogger == 1.2.*, + binary == 0.5.1.*, + bytestring == 0.9.*, + binary-strict == 0.4.*, + parsec == 3.1.*, + syb == 0.3.*, + bimap == 0.2.*, + network == 2.3.* + exposed-modules: + Frenetic.Common, + Frenetic.Compat, + Frenetic.EthernetAddress, + Frenetic.NetCore, + Frenetic.NetCore.Semantics, + Frenetic.NetCore.Short, + Frenetic.NetCore.Types, + Frenetic.NetworkFrames, + Frenetic.Pattern, + Frenetic.Server + other-modules: + Frenetic.Hosts.Nettle, + Frenetic.NetCore.Compiler, + Frenetic.NetCore.Pretty, + Frenetic.NetCore.Reduce, + Frenetic.NettleEx, + Frenetic.Slices.Compile, + Frenetic.Slices.Slice, + Frenetic.Slices.VlanAssignment, + Frenetic.Switches.OpenFlow, + Frenetic.Topo, + Nettle.Ethernet.AddressResolutionProtocol, + Nettle.Ethernet.EthernetAddress, + Nettle.Ethernet.EthernetFrame, + Nettle.IPv4.IPAddress, + Nettle.IPv4.IPPacket, + Nettle.OpenFlow, + Nettle.OpenFlow.Action, + Nettle.OpenFlow.Error, + Nettle.OpenFlow.FlowTable, + Nettle.OpenFlow.Match, + Nettle.OpenFlow.Messages, + Nettle.OpenFlow.MessagesBinary, + Nettle.OpenFlow.Packet, + Nettle.OpenFlow.Port, + Nettle.OpenFlow.Statistics, + Nettle.OpenFlow.StrictPut, + Nettle.OpenFlow.Switch, + Nettle.Servers.Client, + Nettle.Servers.Server + Extensions: + ScopedTypeVariables, TypeFamilies, FlexibleInstances, + FlexibleContexts, DoAndIfThenElse, RecordWildCards + ghc-options: + -fwarn-incomplete-patterns + hs-source-dirs: + src + nettle-openflow/src + cpp-options: "-DOPENFLOW_VERSION=1" + +benchmark frenetic-benchmark + cpp-options: "-DOPENFLOW_VERSION=1" + type: exitcode-stdio-1.0 + build-depends: base >= 4 && < 5, + containers >= 0.4.2.1, + ansi-wl-pprint, + fgl, + multiset >= 0.2.1, + mtl >= 2.0.1.0, + process, + random, + HList, + hslogger == 1.2.*, + binary == 0.5.1.*, + bytestring == 0.9.*, + binary-strict == 0.4.*, + parsec == 3.1.*, + syb == 0.3.*, + bimap == 0.2.*, + network == 2.3.* + Extensions: ScopedTypeVariables, TypeFamilies, FlexibleInstances, + FlexibleContexts, DoAndIfThenElse, RecordWildCards + ghc-options: + -fwarn-incomplete-patterns + hs-source-dirs: src + nettle-openflow/src + Main-Is: Benchmark.hs + +Test-Suite frenetic-tests + type: + exitcode-stdio-1.0 + cpp-options: "-DOPENFLOW_VERSION=1" + main-is: + Main.hs + build-depends: + ansi-wl-pprint, + base, + containers, + fgl, + multiset, + mtl, + process, + random, + QuickCheck >= 2, + HUnit, + test-framework, + test-framework-th, + test-framework-hunit, + test-framework-quickcheck2, + HList, + hslogger == 1.2.*, + binary == 0.5.1.*, + bytestring == 0.9.*, + binary-strict == 0.4.*, + parsec == 3.1.*, + syb == 0.3.*, + bimap == 0.2.*, + network == 2.3.* + ghc-options: + -fwarn-incomplete-patterns + Extensions: + ScopedTypeVariables, TypeFamilies, FlexibleInstances, + FlexibleContexts, TemplateHaskell, DoAndIfThenElse, RecordWildCards + hs-source-dirs: + testsuite, + src, + nettle-openflow/src diff --git a/nettle-openflow/src/Nettle/Ethernet/AddressResolutionProtocol.hs b/nettle-openflow/src/Nettle/Ethernet/AddressResolutionProtocol.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/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/nettle-openflow/src/Nettle/Ethernet/EthernetAddress.hs b/nettle-openflow/src/Nettle/Ethernet/EthernetAddress.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/src/Nettle/Ethernet/EthernetAddress.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +module Nettle.Ethernet.EthernetAddress ( + -- * Ethernet address + 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. 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 :: Strict.Get EthernetAddress +getEthernetAddress = + 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 -> 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 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/nettle-openflow/src/Nettle/Ethernet/EthernetFrame.hs b/nettle-openflow/src/Nettle/Ethernet/EthernetFrame.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/src/Nettle/Ethernet/EthernetFrame.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE BangPatterns #-} + +-- | This module provides data structures for Ethernet frames +-- as well as parsers and unparsers for Ethernet frames. +module Nettle.Ethernet.EthernetFrame ( + + -- * Data types + EthernetFrame(..) + , EthernetBody(..) + , EthernetHeader(..) + , EthernetTypeCode + , ethTypeVLAN + , ethTypeIP + , ethTypeARP + , ethTypeLLDP + , typeEth2Cutoff + , VLANPriority + , VLANID + , eth_ip_packet + , eth_ip_tcp_packet + , eth_ip_udp_packet + , foldEthernetFrame + , foldEthernetBody + + -- * Parsers and unparsers + , getEthernetFrame + , getEthHeader + , getEthernetFrame2 + , getEthHeader2 + , putEthHeader + , putEthFrame + + -- * ARP frames + , arpQuery + , arpReply + + ) where + +import Nettle.Ethernet.EthernetAddress +import Nettle.IPv4.IPPacket +import Nettle.IPv4.IPAddress +import Nettle.Ethernet.AddressResolutionProtocol +import qualified Data.ByteString as B +import Data.Binary +import Data.Binary.Get +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 + +-- | 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 + + +data EthernetBody = IPInEthernet !IPPacket + | ARPInEthernet !ARPPacket + | UninterpretedEthernetBody !B.ByteString + deriving (Show,Eq) + +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. +type EthernetTypeCode = Word16 + +type VLANID = Word16 + + +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 + } + ) + + +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 + } + ) + + +-- | Parser for Ethernet frames. +getEthernetFrame :: Strict.Get EthernetFrame +getEthernetFrame = do + hdr <- {-# SCC "getEthHeader" #-} getEthHeader + -- r <- Strict.remaining + if typeCode hdr == ethTypeIP + 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 -> + do r <- Strict.remaining + body <- Strict.getByteString r + return $ hCons hdr (hCons (UninterpretedEthernetBody B.empty) hNil) + else do r <- Strict.remaining + 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. +getEthHeader2 :: Binary.Get EthernetHeader +getEthHeader2 = do + dstAddr <- getEthernetAddress2 + srcAddr <- getEthernetAddress2 + tcode <- Binary.getWord16be + if tcode < typeEth2Cutoff + then error "don't know how to parse this kind of ethernet frame" + else if (tcode == ethTypeVLAN) + 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 -> Strict.Put +putEthHeader (EthernetHeader dstAddr srcAddr tcode) = + do putEthernetAddress dstAddr + putEthernetAddress srcAddr + Strict.putWord16be tcode +putEthHeader (Ethernet8021Q dstAddr srcAddr tcode pcp cfi vid) = + do putEthernetAddress dstAddr + putEthernetAddress srcAddr + 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 +ethTypeLLDP = 0x88CC +ethTypeVLAN = 0x8100 +typeEth2Cutoff = 0x0600 + + +clearBits :: Bits a => a -> [Int] -> a +clearBits = foldl clearBit + diff --git a/nettle-openflow/src/Nettle/IPv4/IPAddress.hs b/nettle-openflow/src/Nettle/IPv4/IPAddress.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/src/Nettle/IPv4/IPAddress.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE BangPatterns #-} + +module Nettle.IPv4.IPAddress where + +import Data.Word +import Data.Bits +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] + +getIPAddress :: Get IPAddress +getIPAddress = getWord32be >>= return . IPAddress +{-# INLINE getIPAddress #-} + +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 = complement (2^(32 - fromIntegral len) - 1) + +addressPart :: IPAddressPrefix -> IPAddress +addressPart (IPAddress a,l) = IPAddress a +{-# INLINE addressPart #-} + +prefixLength :: IPAddressPrefix -> PrefixLength +prefixLength (_,l) = l +{-# INLINE prefixLength #-} + +maxPrefixLen :: Word8 +maxPrefixLen = 32 + +prefixIsExact :: IPAddressPrefix -> Bool +prefixIsExact (_,l) = l==maxPrefixLen + +defaultIPPrefix = ipAddress 0 0 0 0 // 0 + +addressToOctets :: IPAddress -> (Word8, Word8, Word8, Word8) +addressToOctets (IPAddress addr) = (b1,b2,b3,b4) + where b4 = fromIntegral $ addr .&. (2^8 - 1) + b3 = fromIntegral $ shiftR (addr .&. (2^16 - 1)) 8 + b2 = fromIntegral $ shiftR (addr .&. (2^24 - 1)) 16 + b1 = fromIntegral $ shiftR (addr .&. (2^32 - 1)) 24 + +showOctets :: IPAddress -> String +showOctets addr = show b1 ++ "." ++ show b2 ++ "." ++ show b3 ++ "." ++ show b4 + where (b1,b2,b3,b4) = addressToOctets addr + +showPrefix :: IPAddressPrefix -> String +showPrefix (addr, len) = showOctets addr ++ "/" ++ show len + +prefixPlus :: IPAddressPrefix -> Word32 -> IPAddress +prefixPlus (IPAddress addr,_) x = IPAddress (addr + x) + +prefixOverlaps :: IPAddressPrefix -> IPAddressPrefix -> Bool +prefixOverlaps p1@(IPAddress addr, len) p2@(IPAddress addr', len') + | addr .&. mask == addr' .&. mask = True + | otherwise = False + where len'' = min len len' + mask = foldl setBit (0 :: Word32) [(32 - fromIntegral len'')..31] + +elemOfPrefix :: IPAddress -> IPAddressPrefix -> Bool +elemOfPrefix addr prefix = (addr // 32) `prefixOverlaps` prefix + +intersect :: IPAddressPrefix -> IPAddressPrefix -> Maybe IPAddressPrefix +intersect p1@(_, len1) p2@(_, len2) + | p1 `prefixOverlaps` p2 = Just longerPrefix + | otherwise = Nothing + where longerPrefix = if len1 < len2 then p2 else p1 + +intersects :: [IPAddressPrefix] -> Maybe IPAddressPrefix +intersects = foldl f (Just defaultIPPrefix) + where f mpref pref = maybe Nothing (intersect pref) mpref + +disjoint :: IPAddressPrefix -> IPAddressPrefix -> Bool +disjoint p1 p2 = not (p1 `prefixOverlaps` p2) + +disjoints :: [IPAddressPrefix] -> Bool +disjoints = isNothing . intersects + +isSubset :: IPAddressPrefix -> IPAddressPrefix -> Bool +isSubset p1@(_,l) p2@(_,l') = l <= l' && (p1 `prefixOverlaps` p2) + +parseIPAddress :: String -> Maybe IPAddress +parseIPAddress s = case parse ipAddressParser "" s of + Right a -> Just a + Left _ -> Nothing + +ipAddressParser :: CharParser () IPAddress +ipAddressParser = do a <- many1 digit + char '.' + b <- many1 digit + char '.' + c <- many1 digit + char '.' + d <- many1 digit + return $ ipAddress (read a) (read b) (read c) (read d) diff --git a/nettle-openflow/src/Nettle/IPv4/IPPacket.hs b/nettle-openflow/src/Nettle/IPv4/IPPacket.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/src/Nettle/IPv4/IPPacket.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE TypeSynonymInstances, TypeOperators, MultiParamTypeClasses, FunctionalDependencies, RecordWildCards #-} +{-# LANGUAGE BangPatterns #-} + +{-| + +This module provides @Get@ values for parsing various +IP packets and headers from ByteStrings into a byte-sequence-independent +representation as Haskell datatypes. + +Warning: + +These are incomplete. The headers may not contain all the information +that the protocols specify. For example, the Haskell representation of an IP Header +only includes source and destination addresses and IP protocol number, even though +an IP packet has many more header fields. More seriously, an IP header may have an optional +extra headers section after the destination address. We assume this is not present. If it is present, +then the transport protocol header will not be directly after the destination address, but will be after +these options. Therefore functions that assume this, such as the getExactMatch function below, will give +incorrect results when applied to such IP packets. + +The Haskell representations of the headers for the transport protocols are similarly incomplete. +Again, the Get instances for the transport protocols may not parse through the end of the +transport protocol header. + +-} +module Nettle.IPv4.IPPacket ( + -- * IP Packet + IPPacket(..) + , IPHeader(..) + , DifferentiatedServicesCodePoint + , FragOffset + , IPProtocol + , IPTypeOfService + , TransportPort + , ipTypeTcp + , ipTypeUdp + , ipTypeIcmp + , IPBody(..) + , fromTCPPacket + , fromUDPPacket + , withIPPacket + , foldIPPacket + , foldIPBody + + -- * Parsers + , getIPPacket + , getIPPacket2 + , getIPHeader + , ICMPHeader + , ICMPType + , ICMPCode + , getICMPHeader + , TCPHeader + , TCPPortNumber + , getTCPHeader + , UDPHeader + , UDPPortNumber + , getUDPHeader + ) where + +import Nettle.IPv4.IPAddress +import Data.Bits +import Data.Word +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. +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 + } + deriving (Read,Show,Eq) + +type DifferentiatedServicesCodePoint = Word8 +type FragOffset = Word16 +type IPProtocol = Word8 +type IPTypeOfService = Word8 +type TransportPort = Word16 + +ipTypeTcp, ipTypeUdp, ipTypeIcmp :: IPProtocol + +ipTypeTcp = 6 +ipTypeUdp = 17 +ipTypeIcmp = 1 + +-- | The body of an IP packet can be either a TCP, UDP, ICMP or other packet. +-- Packets other than TCP, UDP, ICMP are represented as unparsed @ByteString@ values. +data IPBody = TCPInIP TCPHeader + | UDPInIP UDPHeader S.ByteString + | ICMPInIP ICMPHeader + | UninterpretedIPBody B.ByteString + deriving (Show,Eq) + + +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 + diffServ <- getWord8 + totalLen <- getWord16be + ident <- getWord16be + flagsAndFragOffset <- getWord16be + ttl <- getWord8 + nwproto <- getIPProtocol + hdrChecksum <- getWord16be + nwsrc <- getIPAddress + nwdst <- getIPAddress + return (IPHeader { ipSrcAddress = nwsrc + , ipDstAddress = nwdst + , ipProtocol = nwproto + , headerLength = fromIntegral (b1 .&. 0x0f) + , totalLength = fromIntegral totalLen + , dscp = shiftR diffServ 2 + } ) +{-# 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 #-} + +getIPProtocol2 :: Binary.Get IPProtocol +getIPProtocol2 = Binary.getWord8 + + +getIPPacket :: Get IPPacket +getIPPacket = do + 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 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 + +type ICMPHeader = (ICMPType, ICMPCode) +type ICMPType = Word8 +type ICMPCode = Word8 + +getICMPHeader :: Get ICMPHeader +getICMPHeader = do + icmp_type <- getWord8 + icmp_code <- getWord8 + skip 6 + return (icmp_type, icmp_code) +{-# 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 + +getTCPHeader :: Get TCPHeader +getTCPHeader = do + 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 + +getUDPHeader :: Get UDPHeader +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/nettle-openflow/src/Nettle/OpenFlow.hs b/nettle-openflow/src/Nettle/OpenFlow.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/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/nettle-openflow/src/Nettle/OpenFlow/Action.hs b/nettle-openflow/src/Nettle/OpenFlow/Action.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/src/Nettle/OpenFlow/Action.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE CPP #-} + +module Nettle.OpenFlow.Action ( + -- * Actions + Action (..) + , ActionType (..) + , PseudoPort (..) + , MaxLenToSendController + , VendorID + , QueueID + -- * Action sequences + , ActionSequence(..) + , sendOnPort, sendOnInPort, flood, drop, allPhysicalPorts, processNormally, sendToController, processWithTable + , setVlanVID, setVlanPriority, stripVlanHeader, setEthSrcAddr, setEthDstAddr + , setIPSrcAddr, setIPDstAddr + , setIPToS + , setTransportSrcPort + , setTransportDstPort + , enqueue + , vendorAction + ) where + +import Prelude hiding (drop) +import Nettle.OpenFlow.Port +import Nettle.Ethernet.EthernetAddress +import Nettle.Ethernet.EthernetFrame +import Nettle.IPv4.IPAddress +import Nettle.IPv4.IPPacket +import Data.Word + + +-- |The supported switch actions are denoted with these symbols. +data ActionType = OutputToPortType + | SetVlanVIDType + | SetVlanPriorityType + | StripVlanHeaderType + | SetEthSrcAddrType + | SetEthDstAddrType + | SetIPSrcAddrType + | SetIPDstAddrType + | SetIPTypeOfServiceType + | SetTransportSrcPortType + | SetTransportDstPortType + | EnqueueType + | VendorActionType + deriving (Show,Read,Eq,Ord,Enum) + +-- | Each flow table entry contains a list of actions that will +-- be executed when a packet matches the entry. +-- Specification: @ofp_action_header@ and all @ofp_action_*@ structures. +data Action + = SendOutPort PseudoPort -- ^send out given port + | SetVlanVID VLANID -- ^set the 802.1q VLAN ID + | SetVlanPriority VLANPriority -- ^set the 802.1q priority + | StripVlanHeader -- ^strip the 802.1q header + | SetEthSrcAddr EthernetAddress -- ^set ethernet source address + | SetEthDstAddr EthernetAddress -- ^set ethernet destination address + | SetIPSrcAddr IPAddress -- ^set IP source address + | SetIPDstAddr IPAddress -- ^set IP destination address + | SetIPToS IPTypeOfService -- ^IP ToS (DSCP field) + | SetTransportSrcPort TransportPort -- ^set TCP/UDP source port + | SetTransportDstPort TransportPort -- ^set TCP/UDP destination port + | Enqueue { + enqueuePort :: PortID, -- ^port the queue belongs to + queueID :: QueueID -- ^where to enqueue the packets + } -- ^output to queue + | VendorAction VendorID [Word8] + deriving (Show,Eq) + + +-- | A @PseudoPort@ denotes the target of a forwarding +-- action. +data PseudoPort = PhysicalPort PortID -- ^send out physical port with given id + | InPort -- ^send packet out the input port + | Flood -- ^send out all physical ports except input port and those disabled by STP + | AllPhysicalPorts -- ^send out all physical ports except input port + | ToController MaxLenToSendController -- ^send to controller + | NormalSwitching -- ^process with normal L2/L3 switching + | WithTable -- ^process packet with flow table + deriving (Show,Read, Eq) + +-- | A send to controller action includes the maximum +-- number of bytes that a switch will send to the +-- controller. +type MaxLenToSendController = Word16 + +type VendorID = Word32 +type QueueID = Word32 + +-- | Sequence of actions, represented as finite lists. The Monoid instance of +-- lists provides methods for denoting the do-nothing action (@mempty@) and for concatenating action sequences @mconcat@. +type ActionSequence = [Action] + +-- | send p is a packet send action. +send :: PseudoPort -> ActionSequence +send p = [SendOutPort p] + +sendOnPort :: PortID -> ActionSequence +sendOnPort p = [SendOutPort $ PhysicalPort p] + +sendOnInPort, flood, drop, allPhysicalPorts, processNormally :: ActionSequence +sendOnInPort = send InPort +flood = send Flood +drop = [] +allPhysicalPorts = send AllPhysicalPorts +processNormally = send NormalSwitching +processWithTable = send WithTable + +sendToController :: MaxLenToSendController -> ActionSequence +sendToController maxlen = send (ToController maxlen) + +setVlanVID :: VLANID -> ActionSequence +setVlanVID vlanid = [SetVlanVID vlanid] + +setVlanPriority :: VLANPriority -> ActionSequence +setVlanPriority x = [SetVlanPriority x] + +stripVlanHeader :: ActionSequence +stripVlanHeader = [StripVlanHeader] + +setEthSrcAddr :: EthernetAddress -> ActionSequence +setEthSrcAddr addr = [SetEthSrcAddr addr] + +setEthDstAddr :: EthernetAddress -> ActionSequence +setEthDstAddr addr = [SetEthDstAddr addr] + +setIPSrcAddr :: IPAddress -> ActionSequence +setIPSrcAddr addr = [SetIPSrcAddr addr] + +setIPDstAddr :: IPAddress -> ActionSequence +setIPDstAddr addr = [SetIPDstAddr addr] + +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 +setIPToS :: IPTypeOfService -> ActionSequence +setIPToS tos = [SetIPToS tos] +#endif + +setTransportSrcPort :: TransportPort -> ActionSequence +setTransportSrcPort port = [SetTransportSrcPort port] + +setTransportDstPort :: TransportPort -> ActionSequence +setTransportDstPort port = [SetTransportDstPort port] + + +#if OPENFLOW_VERSION==1 +enqueue :: PortID -> QueueID -> ActionSequence +enqueue portid queueid = [Enqueue portid queueid] + +vendorAction :: VendorID -> [Word8] -> ActionSequence +vendorAction vid bytes = [VendorAction vid bytes] +#endif + + + diff --git a/nettle-openflow/src/Nettle/OpenFlow/Error.hs b/nettle-openflow/src/Nettle/OpenFlow/Error.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/src/Nettle/OpenFlow/Error.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE CPP #-} + +module Nettle.OpenFlow.Error ( + SwitchError (..) + , HelloFailure (..) + , RequestError (..) + , ActionError (..) + , FlowModError (..) + , PortModError (..) +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + , QueueOpError (..) +#endif + ) where + +import Data.Word + +-- | When a switch encounters an error condition, it sends the controller +-- a message containing the information in @SwitchErrorRecord@. +data SwitchError = HelloFailed HelloFailure String + | BadRequest RequestError [Word8] +#if OPENFLOW_VERSION==151 + | BadAction Word16 [Word8] + | FlowModFailed Word16 [Word8] +#endif +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + | BadAction ActionError [Word8] + | FlowModFailed FlowModError [Word8] + | PortModFailed PortModError [Word8] + | QueueOperationFailed QueueOpError [Word8] +#endif + deriving (Show, Eq) + +data HelloFailure = IncompatibleVersions +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + | HelloPermissionsError +#endif + deriving (Show, Eq, Ord, Enum) + +data RequestError = VersionNotSupported + | MessageTypeNotSupported + | StatsRequestTypeNotSupported + | VendorNotSupported + | VendorSubtypeNotSupported + | RequestPermissionsError +#if OPENFLOW_VERSION==1 + | BadRequestLength + | BufferEmpty + | UnknownBuffer +#endif + deriving (Show, Eq, Ord, Enum) + + +data ActionError = UnknownActionType + | BadActionLength + | UnknownVendorID + | UnknownActionTypeForVendor + | BadOutPort + | BadActionArgument +#if OPENFLOW_VERSION==152 || OPENFLOW_VERSION==1 + | ActionPermissionsError +#endif +#if OPENFLOW_VERSION==1 + | TooManyActions + | InvalidQueue +#endif + deriving (Show, Eq, Ord, Enum) + +data FlowModError = TablesFull + | OverlappingFlow + | FlowModPermissionsError + | EmergencyModHasTimeouts +#if OPENFLOW_VERSION==1 + | BadCommand + | UnsupportedActionList +#endif + deriving (Show, Eq, Ord, Enum) + +data PortModError = BadPort | BadHardwareAddress deriving (Show, Eq, Ord, Enum) + +data QueueOpError = QueueOpBadPort | QueueDoesNotExist | QueueOpPermissionsError deriving (Show, Eq, Ord, Enum) + diff --git a/nettle-openflow/src/Nettle/OpenFlow/FlowTable.hs b/nettle-openflow/src/Nettle/OpenFlow/FlowTable.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/src/Nettle/OpenFlow/FlowTable.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE CPP, DisambiguateRecordFields #-} +-- | A switch has some number of flow tables. Each flow table is a +-- prioritized list of entries containing a @Match@, a list of +-- @Action@s, and other options affecting the behavior of the switch. +-- This module represents the OpenFlow messages that can be used +-- to modify flow tables. +module Nettle.OpenFlow.FlowTable ( + FlowTableID + , FlowMod (..) + , Cookie + , Priority + , TimeOut (..) + , FlowRemoved (..) + , FlowRemovalReason (..) + ) where + +import Nettle.OpenFlow.Switch +import Nettle.OpenFlow.Action +import Nettle.OpenFlow.Match +import Nettle.OpenFlow.Packet +import Data.Word +import Data.List as List + +type FlowTableID = Word8 + +data FlowMod = AddFlow { match :: Match + , priority :: Priority + , actions :: ActionSequence + , cookie :: Cookie + , idleTimeOut :: TimeOut + , hardTimeOut :: TimeOut + , notifyWhenRemoved :: Bool + , applyToPacket :: Maybe BufferID + , overlapAllowed :: Bool + } + | AddEmergencyFlow { match :: Match + , priority :: Priority + , actions :: ActionSequence + , cookie :: Cookie + , overlapAllowed :: Bool + } + + | ModifyFlows { match :: Match + , newActions :: ActionSequence + , ifMissingPriority :: Priority + , ifMissingCookie :: Cookie + , ifMissingIdleTimeOut :: TimeOut + , ifMissingHardTimeOut :: TimeOut + , ifMissingNotifyWhenRemoved :: Bool + , ifMissingOverlapAllowed :: Bool + } + | ModifyExactFlow { match :: Match + , priority :: Priority + , newActions :: ActionSequence + , ifMissingCookie :: Cookie + , ifMissingIdleTimeOut :: TimeOut + , ifMissingHardTimeOut :: TimeOut + , ifMissingNotifyWhenRemoved :: Bool + , ifMissingOverlapAllowed :: Bool + } + | DeleteFlows { match :: Match, + outPort :: Maybe PseudoPort + } + | DeleteExactFlow { match :: Match, + outPort :: Maybe PseudoPort, + priority :: Priority + } + + deriving (Show, Eq) + +type Cookie = Word64 + +-- |The priority of a flow entry is a 16-bit integer. Flow entries with higher numeric priorities match before lower ones. +type Priority = Word16 + +-- | Each flow entry has idle and hard timeout values +-- associated with it. +data TimeOut = Permanent + | ExpireAfter Word16 + deriving (Show,Eq) + + +-- | When a switch removes a flow, it may send a message containing the information +-- in @FlowRemovedRecord@ to the controller. +data FlowRemoved = FlowRemovedRecord { flowRemovedMatch :: Match, + flowRemovedCookie :: Word64, + flowRemovedPriority :: Priority, + flowRemovedReason :: FlowRemovalReason, + flowRemovedDuration :: Integer, + flowRemovedDurationNSecs :: Integer, + flowRemovedIdleTimeout :: Integer, + flowRemovedPacketCount :: Integer, + flowRemovedByteCount :: Integer } + deriving (Show,Eq) + +data FlowRemovalReason = IdleTimerExpired + | HardTimerExpired + | DeletedByController + deriving (Show,Eq,Ord,Enum) diff --git a/nettle-openflow/src/Nettle/OpenFlow/Match.hs b/nettle-openflow/src/Nettle/OpenFlow/Match.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/src/Nettle/OpenFlow/Match.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE CPP, DisambiguateRecordFields, RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE BangPatterns #-} + +module Nettle.OpenFlow.Match ( + Match (..) + , matchAny + , 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 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), + 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) + + +-- |A match that matches every packet. +matchAny :: Match +matchAny = Match { inPort = Nothing, + srcEthAddress = Nothing, + dstEthAddress = Nothing, + vLANID = Nothing, + vLANPriority = Nothing, + ethFrameType = Nothing, + ipTypeOfService = Nothing, + matchIPProtocol = Nothing, + srcIPAddress = defaultIPPrefix, + dstIPAddress = defaultIPPrefix, + srcTransportPort = Nothing, + dstTransportPort = Nothing } + +-- | Return True if given 'Match' represents an exact match, i.e. no +-- wildcards and the IP addresses' prefixes cover all bits. +isExactMatch :: Match -> Bool +isExactMatch (Match {..}) = + (isJust inPort) && + (isJust srcEthAddress) && + (isJust dstEthAddress) && + (isJust vLANID) && + (isJust vLANPriority) && + (isJust ethFrameType) && + (isJust ipTypeOfService) && + (isJust matchIPProtocol) && + (prefixIsExact srcIPAddress) && + (prefixIsExact dstIPAddress) && + (isJust srcTransportPort) && + (isJust dstTransportPort) + +ofpVlanNone = 0xffff + + +frameToExactMatch :: PortID -> EthernetFrame -> Match +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) + } + 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 -> Strict.Get Match +getExactMatch inPort = do + frame <- getEthernetFrame + return (frameToExactMatch inPort frame) + + +-- | Models the match semantics of an OpenFlow switch. +matches :: (PortID, EthernetFrame) -> Match -> Bool +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, + maybe True matchesVLANPriority vLANPriority, + maybe True matchesEthFrameType ethFrameType, + maybe True matchesIPProtocol matchIPProtocol, + maybe True matchesIPToS ipTypeOfService', + matchesIPSourcePrefix srcIPAddress, + matchesIPDestPrefix dstIPAddress, + maybe True matchesSrcTransportPort srcTransportPort, + maybe True matchesDstTransportPort dstTransportPort ] + where + ethHeader = hOccurs frame + matchesInPort p = p == inPort + matchesSrcEthAddress a = sourceMACAddress ethHeader == a + matchesDstEthAddress a = destMACAddress ethHeader == a + matchesVLANID a = + case ethHeader of + EthernetHeader {} -> True + Ethernet8021Q {..}-> a == vlanId + matchesVLANPriority a = + case ethHeader of + EthernetHeader {} -> True + Ethernet8021Q {..} -> a == priorityCodePoint + matchesEthFrameType t = t == typeCode ethHeader + matchesIPProtocol protCode = + case eth_ip_packet frame of + Just pkt -> IP.ipProtocol (hOccurs pkt) == protCode + _ -> True + matchesIPToS tos = + case eth_ip_packet frame of + Just pkt -> tos == IP.dscp (hOccurs pkt) + _ -> True + matchesIPSourcePrefix prefix = + case eth_ip_packet frame of + Just pkt -> IP.ipSrcAddress (hOccurs pkt) `elemOfPrefix` prefix + Nothing -> True + matchesIPDestPrefix prefix = + case eth_ip_packet frame of + Just pkt -> IP.ipSrcAddress (hOccurs pkt) `elemOfPrefix` prefix + Nothing -> True + matchesSrcTransportPort sp = + case eth_ip_packet frame of + Just pkt -> + case hOccurs pkt of + IP.TCPInIP (srcPort, _) -> srcPort == sp + IP.UDPInIP (srcPort, _) body -> srcPort == sp + _ -> True + Nothing -> True + matchesDstTransportPort dp = + case eth_ip_packet frame of + Just ipPacket -> + case hOccurs ipPacket of + IP.TCPInIP (_, dstPort) -> dstPort == dp + IP.UDPInIP (_, dstPort) body -> dstPort == dp + _ -> True + Nothing -> True diff --git a/nettle-openflow/src/Nettle/OpenFlow/Messages.hs b/nettle-openflow/src/Nettle/OpenFlow/Messages.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/src/Nettle/OpenFlow/Messages.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP, ScopedTypeVariables #-} + +{-| +This module provides a logical representation of OpenFlow switches and protocol messages. +An OpenFlow message is either a switch-to-controller message or controller-to-switch message. +In either case, each message is tagged with a unique message identifier. +-} +module Nettle.OpenFlow.Messages ( + TransactionID + , SCMessage (..) + , CSMessage (..) + ) where + +import Data.Word +import qualified Nettle.OpenFlow.Port as Port +import Nettle.OpenFlow.Action +import qualified Nettle.OpenFlow.Packet as Packet +import Nettle.OpenFlow.Switch +import Nettle.OpenFlow.Match +import qualified Nettle.OpenFlow.FlowTable as FlowTable +import Nettle.OpenFlow.Statistics +import Nettle.OpenFlow.Error + +-- | Every OpenFlow message is tagged with a MessageID value. +type TransactionID = Word32 + +-- | The Switch can send the following messages to +-- the controller. +data SCMessage = SCHello -- ^ Sent after a switch establishes a TCP connection to the controller + | SCEchoRequest ![Word8] -- ^ Switch requests an echo reply + | SCEchoReply ![Word8] -- ^ Switch responds to an echo request + | Features !SwitchFeatures -- ^ Switch reports its features + | PacketIn !Packet.PacketInfo -- ^ Switch sends a packet to the controller + | PortStatus !Port.PortStatus -- ^ Switch sends port status + | FlowRemoved !FlowTable.FlowRemoved -- ^ Switch reports that a flow has been removed + | StatsReply !StatsReply -- ^ Switch reports statistics + | Error !SwitchError -- ^ Switch reports an error + | BarrierReply -- ^ Switch responds that a barrier has been processed + | 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 + | 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 + | BarrierRequest -- ^ Controller requests a barrier + | SetConfig + | Vendor + | GetQueueConfig !QueueConfigRequest + deriving (Show,Eq) + + diff --git a/nettle-openflow/src/Nettle/OpenFlow/MessagesBinary.hs b/nettle-openflow/src/Nettle/OpenFlow/MessagesBinary.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/src/Nettle/OpenFlow/MessagesBinary.hs @@ -0,0 +1,1894 @@ +{-# LANGUAGE CPP, DisambiguateRecordFields, RecordWildCards, NamedFieldPuns #-} +{-# 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 :: Integral a => MessageTypeCode -> a -> Put + 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 :: Int -> (OFPMatch -> a) -> Maybe a + 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 + + + +----------------------------------- +-- Utilities +----------------------------------- +getWord8s :: Int -> Get [Word8] +getWord8s n = sequence $ replicate n getWord8 + +putWord8s :: [Word8] -> Put +putWord8s bytes = sequence_ [putWord8 b | b <- bytes] + + + diff --git a/nettle-openflow/src/Nettle/OpenFlow/Packet.hs b/nettle-openflow/src/Nettle/OpenFlow/Packet.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/src/Nettle/OpenFlow/Packet.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP, DisambiguateRecordFields, RecordWildCards #-} + +module Nettle.OpenFlow.Packet ( + -- * Sending packets + PacketOut (..) + , bufferedPacketOut + , unbufferedPacketOut + , receivedPacketOut + , BufferID + + -- * Packets not handled by a switch + , PacketInfo (..) + , PacketInReason (..) + , NumBytes + , bufferedAtSwitch + ) where + +import qualified Data.ByteString as B +import Nettle.OpenFlow.Port +import Nettle.OpenFlow.Action +import Nettle.Ethernet.EthernetFrame +import Data.Word +import Data.Maybe (isJust) + +-- | A switch can be remotely commanded to send a packet. The packet +-- can either be a packet buffered at the switch, in which case the +-- bufferID is provided, or it can be specified explicitly by giving +-- the packet data. +data PacketOut + = 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. +-- When it does so, the packet is assigned a bufferID +-- which can be used to refer to that packet. +type BufferID = Word32 + +-- | Constructs a @PacketOut@ value for a packet buffered at a switch. +bufferedPacketOut :: BufferID -> Maybe PortID -> ActionSequence -> PacketOut +bufferedPacketOut bufID inPort actions = + 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 = + 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. +receivedPacketOut :: PacketInfo -> ActionSequence -> PacketOut +receivedPacketOut (PacketInfo {..}) actions = + case bufferID of + Nothing -> unbufferedPacketOut packetData (Just receivedOnPort) actions + Just bufID -> bufferedPacketOut bufID (Just receivedOnPort) actions + + +-- | A switch receives packets on its ports. If the packet matches +-- some flow rules, the highest priority rule is executed. If no +-- flow rule matches, the packet is sent to the controller. When +-- packet is sent to the controller, the switch sends a message +-- containing the following information. +data PacketInfo + = PacketInfo { + bufferID :: !(Maybe BufferID), -- ^buffer ID if packet buffered + packetLength :: !NumBytes, -- ^full length of frame + receivedOnPort :: !PortID, -- ^port on which frame was received + reasonSent :: !PacketInReason, -- ^reason packet is being sent + packetData :: !B.ByteString, -- ^ethernet frame, includes full packet only if no buffer ID + 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 +-- action. +data PacketInReason = NotMatched | ExplicitSend deriving (Show,Read,Eq,Ord,Enum) + +-- | The number of bytes in a packet. +type NumBytes = Int + +bufferedAtSwitch :: PacketInfo -> Bool +bufferedAtSwitch = isJust . bufferID diff --git a/nettle-openflow/src/Nettle/OpenFlow/Port.hs b/nettle-openflow/src/Nettle/OpenFlow/Port.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/src/Nettle/OpenFlow/Port.hs @@ -0,0 +1,101 @@ +module Nettle.OpenFlow.Port ( + Port (..) + , PortID + , SpanningTreePortState (..) + , PortConfigAttribute (..) + , PortFeature (..) + , PortFeatures + , PortMod (..) + , PortStatus + , PortStatusUpdateReason (..) + , portAttributeOn + , portAttributeOff + ) where + +import Data.Word +import Data.Map (Map) +import qualified Data.Map as Map +import Nettle.Ethernet.EthernetAddress + +-- ^ A switch receives and sends packets on a port; The Port data type models attributes of a physical port. +data Port + = Port { + portID :: PortID, -- ^value datapath associates with a physical port + portName :: String, -- ^human-readable interface name + portAddress :: EthernetAddress, -- ^the Ethernet address of the port + portConfig :: [PortConfigAttribute], -- ^describes spanning tree and administrative settings + portLinkDown :: Bool, -- ^describes whether the link is down + portSTPState :: SpanningTreePortState, -- ^describes spanning tree state + portCurrentFeatures :: Maybe PortFeatures, -- ^port's current features + portAdvertisedFeatures :: Maybe PortFeatures, -- ^features advertised by port + portSupportedFeatures :: Maybe PortFeatures, -- ^features supported by port + portPeerFeatures :: Maybe PortFeatures -- ^features advertised by peer + } deriving (Show,Read,Eq) + +type PortID = Word16 + +data SpanningTreePortState = STPListening + | STPLearning + | STPForwarding + | STPBlocking + deriving (Show,Read,Eq,Ord,Enum) + +-- | Possible behaviors of a physical port. Specification: +-- @ofp_port_config@. +data PortConfigAttribute + = PortDown -- ^port is administratively down + | STPDisabled -- ^disable 802.1D spanning tree on this port + | OnlySTPackets -- ^drop all packets except 802.1D spanning tree packets + | NoSTPackets -- ^drop received 802.1D STP packets + | NoFlooding -- ^do not include this port when flooding + | DropForwarded -- ^drop packets forwarded to port + | NoPacketInMsg -- ^do not send packet-in messages for this port + deriving (Show,Read,Eq,Ord,Enum) + +-- | Possible port features. Specification @ofp_port_features@. +data PortFeature + = Rate10MbHD -- ^10 Mb half-duplex rate support + | Rate10MbFD -- ^10 Mb full-duplex rate support + | Rate100MbHD -- ^100 Mb half-duplex rate support + | Rate100MbFD -- ^100 Mb full-duplex rate support + | Rate1GbHD -- ^1 Gb half-duplex rate support + | Rate1GbFD -- ^1 Gb full-duplex rate support + | Rate10GbFD -- ^10 Gb full-duplex rate support + | Copper + | Fiber + | AutoNegotiation + | Pause + | AsymmetricPause + deriving (Show,Read,Eq) + +-- | Set of 'PortFeature's. Specification: bitmap of members in @enum +-- ofp_port_features@. +type PortFeatures = [PortFeature] + +-- |A port can be configured with a @PortMod@ message. +data PortMod + = 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) + attributesToSet :: Map PortConfigAttribute Bool -- ^ attributes mapped to true will be set on, + -- attributes mapped to false will be turned off, + -- and attributes missing will be unchanged + } deriving (Show,Read,Eq) + +-- | The @PortStatus@ represents information regarding +-- a change to a port state on a switch. +type PortStatus = (PortStatusUpdateReason, Port) + +-- | The reason that a port status update message +-- was sent. +data PortStatusUpdateReason = PortAdded + | PortDeleted + | PortModified + deriving (Show,Read,Eq,Ord,Enum) + +portAttributeOn :: PortID -> EthernetAddress -> PortConfigAttribute -> PortMod +portAttributeOn portID addr attr = PortModRecord portID addr (Map.singleton attr True) + +portAttributeOff :: PortID -> EthernetAddress -> PortConfigAttribute -> PortMod +portAttributeOff portID addr attr = PortModRecord portID addr (Map.singleton attr False) diff --git a/nettle-openflow/src/Nettle/OpenFlow/Statistics.hs b/nettle-openflow/src/Nettle/OpenFlow/Statistics.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/src/Nettle/OpenFlow/Statistics.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE CPP #-} + +module Nettle.OpenFlow.Statistics ( + StatsRequest (..) + , TableQuery (..) +#if OPENFLOW_VERSION==1 + , PortQuery (..) + , QueueQuery (..) +#endif + , StatsReply (..) + , MoreToFollowFlag + , FlowStats (..) + , AggregateFlowStats (..) + , TableStats (..) + , PortStats (..) + , nullPortStats + , zeroPortStats + , liftIntoPortStats1 + , liftIntoPortStats2 + , Description (..) +#if OPENFLOW_VERSION==1 + , QueueStats (..) +#endif + ) where + +import Data.Word +import Nettle.OpenFlow.Port +import Nettle.OpenFlow.Match +import Nettle.OpenFlow.Action +import Nettle.OpenFlow.FlowTable +import Control.Monad (liftM,liftM2) + +data StatsRequest + = FlowStatsRequest { + statsRequestMatch :: Match, -- ^fields to match + statsRequestTableID :: TableQuery, -- ^ID of table to read + statsRequestPort :: Maybe PseudoPort -- ^if present, require matching entries to include this as an output port + } + | AggregateFlowStatsRequest { + statsRequestMatch :: Match, -- ^fields to match + statsRequestTableID :: TableQuery, -- ^ID of table to read + statsRequestPort :: Maybe PseudoPort -- ^if present, require matching entries to include this as an output port + } + | TableStatsRequest + | DescriptionRequest +#if OPENFLOW_VERSION==151 || OPENFLOW_VERSION==152 + | PortStatsRequest +#endif +#if OPENFLOW_VERSION==1 + | PortStatsRequest { + portStatsQuery :: PortQuery + } + | QueueStatsRequest { queueStatsPort :: PortQuery, queueStatsQuery:: QueueQuery } +#endif + deriving (Show,Eq) + +#if OPENFLOW_VERSION==1 +data PortQuery = AllPorts | SinglePort PortID deriving (Show,Eq,Ord) +data QueueQuery = AllQueues | SingleQueue QueueID deriving (Show,Eq,Ord) +#endif + +data TableQuery = AllTables +#if OPENFLOW_VERSION==1 + | EmergencyTable +#endif + | Table FlowTableID + deriving (Show,Eq) + + + +data StatsReply + = DescriptionReply Description + | FlowStatsReply MoreToFollowFlag [FlowStats] + | AggregateFlowStatsReply AggregateFlowStats + | TableStatsReply MoreToFollowFlag [TableStats] + | PortStatsReply MoreToFollowFlag [(PortID,PortStats)] +#if OPENFLOW_VERSION==1 + | QueueStatsReply MoreToFollowFlag [QueueStats] +#endif + deriving (Show,Eq) + +type MoreToFollowFlag = Bool + +data Description = Description { manufacturerDesc :: String + , hardwareDesc :: String + , softwareDesc :: String + , serialNumber :: String +#if OPENFLOW_VERSION==1 + , datapathDesc :: String +#endif + } deriving (Show,Eq) + +data AggregateFlowStats = + AggregateFlowStats { aggregateFlowStatsPacketCount :: Integer, + aggregateFlowStatsByteCount :: Integer, + aggregateFlowStatsFlowCount :: Integer + } deriving (Show, Eq) + + +data FlowStats = FlowStats { + flowStatsTableID :: FlowTableID, -- ^ Table ID of the flow + flowStatsMatch :: Match, -- ^ Match condition of the flow + flowStatsActions :: [Action], -- ^ Actions for the flow + flowStatsPriority :: Priority, -- ^ Priority of the flow entry (meaningful when the match is not exact). +#if OPENFLOW_VERSION==1 + flowStatsCookie :: Cookie, -- ^ Cookie associated with the flow. +#endif + flowStatsDurationSeconds :: Integer, +#if OPENFLOW_VERSION==1 + flowStatsDurationNanoseconds :: Integer, +#endif + flowStatsIdleTimeout :: Integer, + flowStatsHardTimeout :: Integer, + flowStatsPacketCount :: Integer, + flowStatsByteCount :: Integer + } + deriving (Show,Eq) + +data TableStats = + TableStats { + tableStatsTableID :: FlowTableID, + tableStatsTableName :: String, + tableStatsMaxEntries :: Integer, + tableStatsActiveCount :: Integer, + tableStatsLookupCount :: Integer, + tableStatsMatchedCount :: Integer } deriving (Show,Eq) + +data PortStats + = PortStats { + portStatsReceivedPackets :: Maybe Double, + portStatsSentPackets :: Maybe Double, + portStatsReceivedBytes :: Maybe Double, + portStatsSentBytes :: Maybe Double, + portStatsReceiverDropped :: Maybe Double, + portStatsSenderDropped :: Maybe Double, + portStatsReceiveErrors :: Maybe Double, + portStatsTransmitError :: Maybe Double, + portStatsReceivedFrameErrors :: Maybe Double, + portStatsReceiverOverrunError :: Maybe Double, + portStatsReceiverCRCError :: Maybe Double, + portStatsCollisions :: Maybe Double + } deriving (Show,Eq) + +-- | A port stats value with all fields missing. +nullPortStats :: PortStats +nullPortStats = PortStats { + portStatsReceivedPackets = Nothing, + portStatsSentPackets = Nothing, + portStatsReceivedBytes = Nothing, + portStatsSentBytes = Nothing, + portStatsReceiverDropped = Nothing, + portStatsSenderDropped = Nothing, + portStatsReceiveErrors = Nothing, + portStatsTransmitError = Nothing, + portStatsReceivedFrameErrors = Nothing, + portStatsReceiverOverrunError = Nothing, + portStatsReceiverCRCError = Nothing, + portStatsCollisions = Nothing + } + +-- | A port stats value with all fields present, but set to 0. +zeroPortStats :: PortStats +zeroPortStats = + PortStats { + portStatsReceivedPackets = Just 0, + portStatsSentPackets = Just 0, + portStatsReceivedBytes = Just 0, + portStatsSentBytes = Just 0, + portStatsReceiverDropped = Just 0, + portStatsSenderDropped = Just 0, + portStatsReceiveErrors = Just 0, + portStatsTransmitError = Just 0, + portStatsReceivedFrameErrors = Just 0, + portStatsReceiverOverrunError = Just 0, + portStatsReceiverCRCError = Just 0, + portStatsCollisions = Just 0 + } + +-- | Lift a unary function and apply to every member of a PortStats record. +liftIntoPortStats1 :: (Double -> Double) -> PortStats -> PortStats +liftIntoPortStats1 f pr1 = + PortStats { portStatsReceivedPackets = liftM f (portStatsReceivedPackets pr1), + portStatsSentPackets = liftM f (portStatsSentPackets pr1), + portStatsReceivedBytes = liftM f (portStatsReceivedBytes pr1), + portStatsSentBytes = liftM f (portStatsSentBytes pr1), + portStatsReceiverDropped = liftM f (portStatsReceiverDropped pr1), + portStatsSenderDropped = liftM f (portStatsSenderDropped pr1), + portStatsReceiveErrors = liftM f (portStatsReceiveErrors pr1), + portStatsTransmitError = liftM f (portStatsTransmitError pr1), + portStatsReceivedFrameErrors = liftM f (portStatsReceivedFrameErrors pr1), + portStatsReceiverOverrunError = liftM f (portStatsReceiverOverrunError pr1), + portStatsReceiverCRCError = liftM f (portStatsReceiverCRCError pr1), + portStatsCollisions = liftM f (portStatsCollisions pr1) + } + +-- | Lift a binary function and apply to every member of a PortStats record. +liftIntoPortStats2 :: (Double -> Double -> Double) -> PortStats -> PortStats -> PortStats +liftIntoPortStats2 f pr1 pr2 = + PortStats { portStatsReceivedPackets = liftM2 f (portStatsReceivedPackets pr1) (portStatsReceivedPackets pr2), + portStatsSentPackets = liftM2 f (portStatsSentPackets pr1) (portStatsSentPackets pr2), + portStatsReceivedBytes = liftM2 f (portStatsReceivedBytes pr1) (portStatsReceivedBytes pr2), + portStatsSentBytes = liftM2 f (portStatsSentBytes pr1) (portStatsSentBytes pr2), + portStatsReceiverDropped = liftM2 f (portStatsReceiverDropped pr1) (portStatsReceiverDropped pr2), + portStatsSenderDropped = liftM2 f (portStatsSenderDropped pr1) (portStatsSenderDropped pr2), + portStatsReceiveErrors = liftM2 f (portStatsReceiveErrors pr1) (portStatsReceiveErrors pr2), + portStatsTransmitError = liftM2 f (portStatsTransmitError pr1) (portStatsTransmitError pr2), + portStatsReceivedFrameErrors = liftM2 f (portStatsReceivedFrameErrors pr1) (portStatsReceivedFrameErrors pr2), + portStatsReceiverOverrunError = liftM2 f (portStatsReceiverOverrunError pr1) (portStatsReceiverOverrunError pr2), + portStatsReceiverCRCError = liftM2 f (portStatsReceiverCRCError pr1) (portStatsReceiverCRCError pr2), + portStatsCollisions = liftM2 f (portStatsCollisions pr1) (portStatsCollisions pr2) + } + + + + +#if OPENFLOW_VERSION==1 +data QueueStats = QueueStats { queueStatsPortID :: PortID, + queueStatsQueueID :: QueueID, + queueStatsTransmittedBytes :: Integer, + queueStatsTransmittedPackets :: Integer, + queueStatsTransmittedErrors :: Integer } deriving (Show,Eq) +#endif diff --git a/nettle-openflow/src/Nettle/OpenFlow/StrictPut.hs b/nettle-openflow/src/Nettle/OpenFlow/StrictPut.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/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/nettle-openflow/src/Nettle/OpenFlow/Switch.hs b/nettle-openflow/src/Nettle/OpenFlow/Switch.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/src/Nettle/OpenFlow/Switch.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE CPP #-} + +module Nettle.OpenFlow.Switch ( + SwitchFeatures (..) + , SwitchID + , SwitchCapability (..) + , maxNumberPorts + , QueueConfigRequest (..) + , QueueConfigReply (..) + , QueueConfig (..) + , QueueLength + , QueueProperty (..) + , QueueRate (..) + ) where + +import Data.Word +import Nettle.OpenFlow.Port +import Nettle.OpenFlow.Action + +-- |The switch features record, summarizes information about a switch +data SwitchFeatures + = SwitchFeatures { + switchID :: SwitchID, -- ^unique switch identifier + packetBufferSize :: Integer, -- ^maximum number of packets buffered at the switch + numberFlowTables :: Integer, -- ^number of flow tables + capabilities :: [SwitchCapability], -- ^switch's capabilities + supportedActions :: [ActionType], -- ^switch's supported actions + ports :: [Port] -- ^description of each port on switch + } deriving (Show,Read,Eq) + +-- |A unique identifier for a switch, also known as DataPathID. +type SwitchID = Word64 + +-- | Maximum number of ports on a switch +maxNumberPorts :: PortID +maxNumberPorts = 0xff00 + + +-- |The switch capabilities are denoted with these symbols +data SwitchCapability = HasFlowStats -- ^can provide flow statistics + | HasTableStats -- ^can provide table statistics + | HasPortStats -- ^can provide port statistics + | SpanningTree -- ^supports the 802.1d spanning tree protocol + | MayTransmitOverMultiplePhysicalInterfaces + | HasQueueStatistics -- ^can provide queue statistics + | CanMatchIPAddressesInARPPackets -- ^match IP addresses in ARP packets + | 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/nettle-openflow/src/Nettle/Servers/Client.hs b/nettle-openflow/src/Nettle/Servers/Client.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/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/nettle-openflow/src/Nettle/Servers/Server.hs b/nettle-openflow/src/Nettle/Servers/Server.hs new file mode 100644 --- /dev/null +++ b/nettle-openflow/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 +import System.Log.Logger + +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 debugM "nettle" ("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/Benchmark.hs b/src/Benchmark.hs new file mode 100644 --- /dev/null +++ b/src/Benchmark.hs @@ -0,0 +1,180 @@ +module Main (main) where + +import Prelude hiding (init) +import Control.Monad +import qualified Data.Map as Map +import Frenetic.NetCore +import Frenetic.NetCore.Pretty +import Frenetic.NetCore.Types (size) +import Frenetic.TopoGen +import Frenetic.PolicyGen +import Frenetic.Slices.Compile +import Frenetic.Slices.VlanAssignment +import Frenetic.Slices.Slice +import Frenetic.Slices.Sat +import System.Console.GetOpt +import System.CPUTime +import System.Environment +import System.Exit +import Text.Printf + +data GraphType = Fattree | Smallworld | Waxman +data PolicyType = ShortestPath | Multicast + +data Options = Options { + optEdge :: Bool +, optAST :: Bool +, optTime :: Bool +, optIso :: Bool +, optComp :: Bool +, optGraph :: GraphType +, optPolicy :: PolicyType +, optNodes :: Int +, optHosts :: Int +} + +defaultOptions :: Options +defaultOptions = Options { + optEdge = False +, optAST = False +, optTime = True +, optIso = False +, optComp = False +, optGraph = Smallworld +, optPolicy = ShortestPath +, optNodes = 20 +, optHosts = 1 +} + +options :: [OptDescr (Options -> IO Options)] +options = + [ + Option ['e'] ["edge"] (NoArg setEdge) "Use edge compiler" + + , Option ['a'] ["ast"] (NoArg setAST) "Measure AST size" + , Option ['l'] ["time"] (NoArg setTime) "Time compilation" + , Option ['i'] ["isolation"] (NoArg setIso) "Time isolation validation" + , Option ['c'] ["compilation"] (NoArg setComp) "Time compilation validation" + + , Option ['f'] ["fattree"] (NoArg setFattree) "Use fattree topology." + , Option ['s'] ["smallworld"] (NoArg setSmallworld) "Use small world random topology." + , Option ['w'] ["waxman"] (NoArg setWaxman) "Use Waxman random topology." + , Option ['p'] ["shortest"] (NoArg setShortest) "Use shortest path routing." + , Option ['m'] ["multicast"] (NoArg setMulticast) "Use multicast routing." + , Option ['n'] ["nodes"] (ReqArg readNodes "NODES") "Number of nodes to use." + , Option ['t'] ["hosts"] (ReqArg readHosts "HOSTS") "Number of hosts per switch." + , Option ['h'] ["help"] (NoArg showHelp) "print this help message" + ] + +setEdge :: Options -> IO Options +setEdge opt = return opt { optEdge = True } + +setAST :: Options -> IO Options +setAST opt = return opt { optAST = True } + +setTime :: Options -> IO Options +setTime opt = return opt { optTime = True } + +setIso :: Options -> IO Options +setIso opt = return opt { optIso = True } + +setComp :: Options -> IO Options +setComp opt = return opt { optComp = True } + +setFattree :: Options -> IO Options +setFattree opt = return opt { optGraph = Fattree } + +setSmallworld :: Options -> IO Options +setSmallworld opt = return opt { optGraph = Smallworld } + +setWaxman :: Options -> IO Options +setWaxman opt = return opt { optGraph = Waxman } + +setMulticast :: Options -> IO Options +setMulticast opt = return opt { optPolicy = Multicast } + +setShortest :: Options -> IO Options +setShortest opt = return opt { optPolicy = ShortestPath } + +readNodes :: String -> Options -> IO Options +readNodes arg opt = return opt { optNodes = read arg } + +readHosts :: String -> Options -> IO Options +readHosts arg opt = return opt { optHosts = read arg } + +showHelp _ = do + putStrLn (usageInfo "Usage Info" options) + exitSuccess + +doWaxman Options {optNodes = nodes, optHosts = hosts} = + waxman nodes hosts 0.8 0.18 + +doSmallworld Options {optNodes = nodes, optHosts = hosts} = + smallworld nodes hosts (max 4 (nodes `quot` 3)) 0.3 + +doFattree _ = return fattree + +start options = do + g <- case optGraph options of + Fattree -> doFattree + Smallworld -> doSmallworld + Waxman -> doWaxman + $ options + let policy = case optPolicy options of + ShortestPath -> shortestPath + Multicast -> multicast + $ g + let slice = (simpleSlice g matchNone) {egress = Map.empty} + let (compiled1, compiled2) = + if optEdge options then + -- Force them to be distinct by adding PoBottom to them. Edge + -- compilation relies on distinct (slice, policy) pairs. + let combined = [(slice, policy), (slice, policy <+> PoBottom)] in + let tagged = edge g combined in + let [c1, c2] = map (\(assignment, (slice, policy)) -> + edgeCompileSlice slice assignment policy) + tagged in + (c1, c2) + else + let c1 = compileSlice slice 1 policy in + let c2 = compileSlice slice 2 policy in + (c1, c2) + when (optTime options) $ do + start <- getCPUTime + let s = size compiled1 + s `seq` return () + finish <- getCPUTime + let diff = (fromIntegral (finish - start)) / (10^12) + printf "Compilation time: %0.3f sec\n" (diff :: Double) + let pSize = size policy + let cSize = size compiled1 + when (optAST options) $ + putStrLn $ "AST Size: " ++ show pSize ++ " -> " ++ show cSize + when (optIso options) $ do + start <- getCPUTime + sep <- separate g compiled1 compiled2 + if not sep then + error "Not separate!" + else return () + finish <- getCPUTime + let diff = (fromIntegral (finish - start)) / (10^12) + printf "Isolation time: %0.3f sec\n" (diff :: Double) + when (optComp options) $ do + start <- getCPUTime + sep <- compiledCorrectly g slice policy compiled1 + if not sep then + error "Not correct!" + else return () + finish <- getCPUTime + let diff = (fromIntegral (finish - start)) / (10^12) + printf "Correctness time: %0.3f sec\n" (diff :: Double) + + +main = do + rawArgs <- getArgs + let (args, unmatched, errors) = getOpt RequireOrder options rawArgs + opts <- foldl (>>=) (return defaultOptions) args + unless (null errors) $ do + mapM_ putStrLn errors + fail "invalid arguments" + start opts diff --git a/src/Frenetic/Common.hs b/src/Frenetic/Common.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/Common.hs @@ -0,0 +1,63 @@ +-- |Functions and types that heavily used by the Frenetic implementation. +module Frenetic.Common + ( Set + , Map + , MultiSet + , ByteString + , module Control.Concurrent.Chan + , module Control.Concurrent + , module System.Log.Logger + , module Data.Monoid + , select + , both + , catMaybes + ) where + +import System.Log.Logger hiding (Priority) +import Control.Concurrent.Chan +import Control.Concurrent +import Control.Monad +import Data.Monoid +import Data.Set (Set) +import Data.Map (Map) +import Data.MultiSet +import Data.ByteString.Lazy (ByteString) +import Data.Maybe (catMaybes) + +-- |Produce a new channel that carries updates from both of the input channels, +-- but does not wait for both to be ready. Analogous to Unix SELECT(2) followed +-- by READ(2) on the ready file descriptor. +select :: Chan a -> Chan b -> IO (Chan (Either a b)) +select chan1 chan2 = do + mergedChan <- newChan + forkIO $ forever $ do + v <- readChan chan1 + writeChan mergedChan (Left v) + forkIO $ forever $ do + v <- readChan chan2 + writeChan mergedChan (Right v) + return mergedChan + +-- |Produce a new channel that waits for both input channels to produce a value, +-- and then yields the latest version of both values. If one channel produces +-- multiple values before the other produces any, then the early values are +-- discarded. Afterwards, whenever one channel updates, the output channel +-- yields that update along with whatever the current version of the other +-- channel is. +both :: Chan a -> Chan b -> IO (Chan (a, b)) +both chan1 chan2 = do + merged <- select chan1 chan2 + result <- newChan + let loop a b = do + v <- readChan merged + case (v, a, b) of + (Left a, _, Nothing) -> loop (Just a) Nothing + (Left a, _, Just b) -> do + writeChan result (a, b) + loop (Just a) (Just b) + (Right b, Nothing, _) -> loop Nothing (Just b) + (Right b, Just a, _) -> do + writeChan result (a, b) + loop (Just a) (Just b) + forkIO (loop Nothing Nothing) + return result diff --git a/src/Frenetic/Compat.hs b/src/Frenetic/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/Compat.hs @@ -0,0 +1,60 @@ +module Frenetic.Compat + ( Packet (..) + , Transmission (..) + -- * Implementation + , FreneticImpl (..) + ) where + +import Frenetic.Common +import Frenetic.NetCore.Types +import qualified Data.List as List +import Data.Bits +import Data.Word +import qualified Data.Set as Set +import Frenetic.Pattern + + +{-| Data that was sent. -} +data Transmission ptrn pkt = Transmission { + trPattern :: ptrn, + trSwitch :: Switch, + trPkt :: pkt + } deriving (Eq) + +-- |'FreneticImpl a' is a family of related abstract types that define a +-- back-end for Frenetic. +class (Show (PatternImpl a), + Show (ActionImpl a), + Matchable (PatternImpl a), + Eq (PacketImpl a), + Eq (ActionImpl a), + Eq (PatternImpl a)) + => FreneticImpl a where + + data PacketImpl a + -- |'PatternImpl a' represents switch-level patterns, which may not be + -- as expressive as Frenetic's pattern language. + -- + -- @patOverapprox@ and @patUnderapprox@ must follow the laws in the + -- Approx class. If the pattern is not a real underapproximation, + -- @patUnderapprox@ must return Nothing. + data PatternImpl a + -- |'ActionImpl a' represents switch-level actions. All Frenetic actions + -- (@Action@) may not be realizable on switches. + data ActionImpl a + + -- |'ptrnMatchPkt pkt pat' is 'True' if 'pat' matches 'pkt'. + ptrnMatchPkt :: PacketImpl a -> PatternImpl a -> Bool + toPacket :: PacketImpl a -> Maybe Packet + + updatePacket :: PacketImpl a -> Packet -> PacketImpl a + + fromPattern :: Pattern -> PatternImpl a + toPattern :: PatternImpl a -> Pattern + + actnDefault :: ActionImpl a + actnController :: ActionImpl a + actnTranslate :: Action -> ActionImpl a + + actnControllerPart :: ActionImpl a -> Switch -> PacketImpl a -> IO () + diff --git a/src/Frenetic/EthernetAddress.hs b/src/Frenetic/EthernetAddress.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/EthernetAddress.hs @@ -0,0 +1,66 @@ +module Frenetic.EthernetAddress + ( EthernetAddress (..) + , ethernetAddress + , broadcastAddress + , ethernetAddress64 + , unpackEthernetAddress + ) where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Numeric (showHex) +import Data.Word +import Data.Bits +import Data.List (intersperse) + +data EthernetAddress = EthernetAddress { unpackEth64 :: Word64 } + deriving (Eq, Ord) + +instance Show EthernetAddress where + show eth = concat $ + intersperse ":" (map (\n -> showHex n "") [w0,w1,w2,w3,w4,w5]) + where (w0,w1,w2,w3,w4,w5) = unpackEthernetAddress eth + +instance Enum EthernetAddress where + toEnum n = EthernetAddress (toEnum n) + fromEnum (EthernetAddress w64) = fromEnum w64 + +instance Binary EthernetAddress where + + get = do + w32 <- getWord32be + w16 <- getWord16be + let w64 = (fromIntegral w32 `shiftL` 16) .|. fromIntegral w16 + return (EthernetAddress w64) + + put (EthernetAddress w64) = do + putWord32be (fromIntegral (shiftR w64 16)) + putWord16be (fromIntegral (w64 `mod` 0x010000)) + +ethernetAddress :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 + -> EthernetAddress +ethernetAddress w1 w2 w3 w4 w5 w6 = EthernetAddress w64 + where w64 = shiftL (fromIntegral w1) 40 .|. + shiftL (fromIntegral w2) 32 .|. + shiftL (fromIntegral w3) 24 .|. + shiftL (fromIntegral w4) 16 .|. + shiftL (fromIntegral w5) 8 .|. + fromIntegral w6 + +broadcastAddress :: EthernetAddress +broadcastAddress = EthernetAddress 0xffffffffffff + +unpackEthernetAddress :: EthernetAddress + -> (Word8,Word8,Word8,Word8,Word8,Word8) +unpackEthernetAddress (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) + +ethernetAddress64 :: Word64 -> EthernetAddress +ethernetAddress64 w64 = EthernetAddress (w64 `mod` 0x01000000000000) diff --git a/src/Frenetic/Hosts/Nettle.hs b/src/Frenetic/Hosts/Nettle.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/Hosts/Nettle.hs @@ -0,0 +1,231 @@ +module Frenetic.Hosts.Nettle where + +import Frenetic.Common +import qualified Data.ByteString as BS +import Data.ByteString.Lazy (toChunks) +import qualified Data.Set as Set +import qualified Data.Map as Map +import Control.Exception.Base +import Control.Monad.State +import System.IO +import Frenetic.NetCore.Pretty +import Frenetic.NetCore.Types +import Frenetic.NetCore.Semantics +import Frenetic.NetCore.Compiler +import Frenetic.Switches.OpenFlow +import Frenetic.Compat +import Data.List (nub, find, intersperse) +import Frenetic.NettleEx + + +mkFlowMod :: (Match, ActionSequence) + -> Priority + -> CSMessage +mkFlowMod (pat, acts) pri = FlowMod AddFlow { + match=pat, + priority=pri, + actions=acts, + cookie=0, + notifyWhenRemoved=False, + idleTimeOut=Permanent, + hardTimeOut=Permanent, + applyToPacket=Nothing, + overlapAllowed=True +} + +rawClassifier :: [(PatternImpl OpenFlow, ActionImpl OpenFlow)] + -> [(Match, ActionSequence)] +rawClassifier classifier = + map (\(p, a) -> (fromOFPat p, fromOFAct a)) classifier + +showMatch Match {..} = "Match {" ++ list ++ "}" where + list = concat . intersperse ", " . catMaybes $ fields + fields = [ case inPort of + Nothing -> Nothing + Just v -> Just $ "inPort = \"" ++ show v ++ "\"" + , case srcEthAddress of + Nothing -> Nothing + Just v -> Just $ "srcEthAddress = \"" ++ show v ++ "\"" + , case dstEthAddress of + Nothing -> Nothing + Just v -> Just $ "dstEthAddress = \"" ++ show v ++ "\"" + , case vLANID of + Nothing -> Nothing + Just v -> Just $ "vLANID = \"" ++ show v ++ "\"" + , case vLANPriority of + Nothing -> Nothing + Just v -> Just $ "vLANPriority = \"" ++ show v ++ "\"" + , case ethFrameType of + Nothing -> Nothing + Just v -> Just $ "ethFrameType = \"" ++ show v ++ "\"" + , case ipTypeOfService of + Nothing -> Nothing + Just v -> Just $ "ipTypeOfService = \"" ++ show v ++ "\"" + , case matchIPProtocol of + Nothing -> Nothing + Just v -> Just $ "matchIPProtocol = \"" ++ show v ++ "\"" + , case srcIPAddress of + v@(_, len) -> if len == 0 then Nothing + else Just $ "srcIPAddress = \"" ++ show v ++ "\"" + , case dstIPAddress of + v@(_, len) -> if len == 0 then Nothing + else Just $ "dstIPAddress = \"" ++ show v ++ "\"" + , case srcTransportPort of + Nothing -> Nothing + Just v -> Just $ "srcTransportPort = \"" ++ show v ++ "\"" + , case dstTransportPort of + Nothing -> Nothing + Just v -> Just $ "dstTransportPort = \"" ++ show v ++ "\"" + ] + +prettyClassifier :: (Match, ActionSequence) -> String +prettyClassifier (match, as) = "(" ++ showMatch match ++ ", " ++ show as ++ ")" + +-- |Installs the static portion of the policy, then react. +handleSwitch :: Nettle + -> SwitchHandle + -> Policy + -> Chan Policy + -> Chan (TransactionID, SCMessage) + -> IO () +handleSwitch nettle switch initPolicy policyChan msgChan = do + -- 1. Clear the flow table + -- 2. In parallel: + -- a. Receive a message from the switch + -- b. Receive a policy + -- 3. Keep the last policy in an accumulator + -- 4. On new message, evaluate it with the last policy (not consistent + -- update!) + -- 5. On new policy, update the switch and accumulator + let switchID = handle2SwitchID switch + policiesAndMessages <- select policyChan msgChan + let loop oldPolicy oldThreads (Left policy) = do + sendToSwitch switch (0, FlowMod (DeleteFlows matchAny Nothing)) + let classifier = compile (handle2SwitchID switch) policy + let flowTbl = rawClassifier classifier + debugM "nettle" $ "policy is \n" ++ toString policy ++ + "\n and flow table is \n" ++ + concat (intersperse "\n" + (map prettyClassifier flowTbl)) + oldThreads + newThreads <- runQueryOnSwitch nettle switch classifier + -- Priority 65535 is for microflow rules from reactive-specialization + let flowMods = zipWith mkFlowMod flowTbl [65534, 65533 ..] + mapM_ (sendToSwitch switch) (zip [0,0..] flowMods) + debugM "nettle" $ "finished reconfiguring switch " ++ + show (handle2SwitchID switch) + nextMsg <- readChan policiesAndMessages + + loop policy newThreads nextMsg + loop policy threads (Right (xid, msg)) = case msg of + PacketIn (pkt@(PacketInfo {receivedOnPort=inPort, + reasonSent=ExplicitSend, + enclosedFrame=Right frame})) -> do + let t = Transmission (toOFPat (frameToExactMatch inPort frame)) + switchID + (toOFPkt pkt) + let actions = interpretPolicy policy t + actnControllerPart (actnTranslate actions) switchID (toOFPkt pkt) + nextMsg <- readChan policiesAndMessages + loop policy threads nextMsg + PacketIn (pkt@(PacketInfo {receivedOnPort=inPort, + reasonSent=NotMatched, + enclosedFrame=Right frame})) -> do + let t = Transmission (toOFPat (frameToExactMatch inPort frame)) + switchID + (toOFPkt pkt) + let actions = interpretPolicy policy t + actnControllerPart (actnTranslate actions) switchID (toOFPkt pkt) + case bufferID pkt of + Nothing -> return () + Just buf -> do + let unCtrl (SendOutPort (ToController _)) = False + unCtrl _ = True + let msg = PacketOut $ + PacketOutRecord (Left buf) (Just inPort) + (filter unCtrl (fromOFAct $ actnTranslate actions)) + sendToSwitch switch (2, msg) + nextMsg <- readChan policiesAndMessages + loop policy threads nextMsg + otherwise -> do + nextMsg <- readChan policiesAndMessages + loop policy threads nextMsg + loop PoBottom (return ()) (Left initPolicy) + +nettleServer :: Chan Policy -> Chan (Loc, ByteString) -> IO () +nettleServer policyChan pktChan = do + server <- startOpenFlowServerEx Nothing 6633 + currentPolicy <- newIORef PoBottom + forkIO $ forever $ do + pol <- readChan policyChan + writeIORef currentPolicy pol + forkIO $ forever $ do + (Loc swID pt, pkt) <- readChan pktChan + let msg = PacketOut $ PacketOutRecord (Right (BS.concat . toChunks $ pkt)) + Nothing (sendOnPort pt) + sendToSwitchWithID server swID (0,msg) + forever $ do + -- Nettle does the OpenFlow handshake + (switch, switchFeatures, msgChan) <- acceptSwitch server + noticeM "controller" $ "switch " ++ show (handle2SwitchID switch) ++ + " connected" + -- reading from a channel removes the messages. We need to dupChan for + -- each switch. + switchPolicyChan <- dupChan policyChan + initPolicy <- readIORef currentPolicy + forkIO (handleSwitch server switch initPolicy switchPolicyChan msgChan) + closeServer server + +-- The classifier (1st arg.) pairs Nettle patterns with Frenetic actions. +-- The actions include queries that are not realizable on switches. +-- We assume the classifier does not have any fully-shadowed patterns. +classifierQueries :: [(PatternImpl OpenFlow, ActionImpl OpenFlow)] + -> [(Query, [Match])] +classifierQueries classifier = map sel queries where + queries = nub (concatMap (actQueries.snd) classifier) + sel query = (query, map (fromOFPat.fst) (filter (hasQuery query) classifier)) + hasQuery query (_, action) = query `elem` actQueries action + +runQueryOnSwitch :: Nettle + -> SwitchHandle + -> [(PatternImpl OpenFlow, ActionImpl OpenFlow)] + -> IO (IO ()) +runQueryOnSwitch nettle switch classifier = do + killFlag <- newIORef False + let mkReq m = StatsRequest (FlowStatsRequest m AllTables Nothing) + switchID = handle2SwitchID switch + runQuery (PktQuery _ _, pats) = do + -- nothing to do on the controller until a PacketIn + return () + runQuery (NumPktQuery qid outChan msDelay counter totalRef lastRef, + pats) = do + let statReqs = map mkReq pats + forkIO $ forever $ do + tid <- myThreadId + threadDelay (msDelay * 1000) + sendTransaction nettle switch statReqs $ \replies -> do + count <- readIORef lastRef + let count' = sum (map (getCount counter) replies) + total <- readIORef totalRef + let total' = total + (count' - count) + kill <- readIORef killFlag + if kill then do + writeIORef lastRef 0 -- assumes all rules evicted + killThread tid + else do + writeIORef lastRef count' + writeIORef totalRef total' + writeChan outChan (switchID, total') + return () + mapM_ runQuery (classifierQueries classifier) + return $ do + writeIORef killFlag True + + +getCount :: Counter -> SCMessage -> Integer +getCount counter msg = case msg of + StatsReply (FlowStatsReply _ stats) -> case counter of + CountPackets -> sum (map flowStatsPacketCount stats) + CountBytes -> sum (map flowStatsByteCount stats) + otherwise -> 0 + diff --git a/src/Frenetic/NetCore.hs b/src/Frenetic/NetCore.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/NetCore.hs @@ -0,0 +1,98 @@ +-- |Everything necessary to build a controller atop NetCore, using Nettle as +-- a backend. +module Frenetic.NetCore + ( -- * OpenFlow Controllers + controller + , dynController + -- * Policies + , Policy (..) + , (==>) + , (<%>) + , (<+>) + -- * Predicates + , Predicate + , exactMatch + , inport + , (<||>) + , (<&&>) + , matchAll + , matchNone + , neg + , prSubtract + , prOr + , prAnd + -- ** Exact match predicate constructors + , onSwitch + , dlSrc + , dlDst + , dlTyp + , dlVlan + , dlNoVlan + , dlVlanPcp + , nwSrc + , nwDst + , nwSrcPrefix + , nwDstPrefix + , nwProto + , nwTos + , tpSrc + , tpDst + , inPort + -- * Actions + , Action + -- ** Constructors + , dropPkt + , forward + , allPorts + , modify + , countBytes + , countPkts + , getPkts + -- ** Modifications + , Modification + , unmodified + -- * Network Elements + , Switch + , Port + , Vlan + , Loc (..) + , Word48 + , broadcastAddress + , EthernetAddress + -- * Packets + , Packet (..) + -- * Packet modifications + , modDlSrc + , modDlDst + , modDlVlan + , modDlVlanPcp + , modNwSrc + , modNwDst + , modNwTos + , modTpSrc + , modTpDst + -- * Channels + , select + , both + -- * Slices + , Slice(..) + -- ** Topology constructors + , Topo + , buildGraph + -- ** Slice constructors + , internalSlice + , simpleSlice + -- ** Compilation + , transform + , transformEdge + , dynTransform + ) where + +import Frenetic.Common +import Frenetic.NetCore.Types +import Frenetic.NetCore.Short +import Frenetic.Pattern +import Frenetic.Server +import Frenetic.Slices.Compile +import Frenetic.Slices.Slice +import Frenetic.Topo diff --git a/src/Frenetic/NetCore/Compiler.hs b/src/Frenetic/NetCore/Compiler.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/NetCore/Compiler.hs @@ -0,0 +1,173 @@ +module Frenetic.NetCore.Compiler + ( compile + , compilePredicate + , Bone (..) -- TODO(arjun): do not export + , Classifier + , classify + , minimizeClassifier + ) where + +import Frenetic.Compat +import Frenetic.Pattern +import Frenetic.Common +import Frenetic.NetCore.Types +import Frenetic.NetCore.Semantics +import Frenetic.NetCore.Short +import Data.Dynamic +import qualified Data.List as List +import Data.Maybe +import qualified Data.Set as Set +import qualified Data.Map as Map + +{-| Input: a function, a value, and two lists. Apply the function to each pair from the two lists and the current value. The function may modify the two lists and modify the current value. -} +cartMap :: (c -> a -> b -> (c, Maybe a, Maybe b)) -> c -> [a] -> [b] -> (c, [a], [b]) +cartMap f c [] ys = (c, [], ys) +cartMap f c (x:xs) ys = + let (c', xo, ys') = cartMap' c x ys in + let (c'', xs', ys'') = cartMap f c' xs ys' in + let xs'' = case xo of { Just x' -> x' : xs'; Nothing -> xs' } in + (c'',xs'',ys'') + where + cartMap' c x [] = (c, Just x, []) + cartMap' c x (y:ys) = + case f c x y of + (c', Just x', Just y') -> + let (c'', xo', ys') = cartMap' c' x' ys in + (c'', xo', y':ys') + (c', Nothing, Just y') -> (c', Nothing, y':ys) + (c', Just x', Nothing) -> cartMap' c' x' ys + (c', Nothing, Nothing) -> (c', Nothing, ys) + +{-| Classifiers are the target of compilation. -} +type Classifier ptrn a = [(ptrn, a)] + +classify :: FreneticImpl a + => Switch + -> PacketImpl a + -> Classifier (PatternImpl a) actn + -> Maybe actn +classify switch pkt rules = foldl f Nothing rules where + f (Just a) (ptrn, actn) = Just a + f Nothing (ptrn, actn) = if ptrnMatchPkt pkt ptrn + then Just actn + else Nothing + +{-| Attempt to reduce the number of rules in the classifier. + + 1. Remove a rule if it is a subset of a higher-priority rule: O(n^2). + 2. NYI + +|-} +minimizeShadowing :: FreneticImpl a + => (b -> PatternImpl a) + -> [b] + -> [b] +minimizeShadowing getPat rules = reverse $ f $ reverse rules + where f [] = [] + f (x:xs) = if any (shadows x) xs + then f xs + else x:(f xs) + shadows a1 a2 = + let p1 = getPat a1 + p2 = getPat a2 + in case intersect p1 p2 of + Nothing -> False + Just p3 -> match p1 p3 + +minimizeClassifier :: FreneticImpl a + => Classifier (PatternImpl a) (ActionImpl a) + -> Classifier (PatternImpl a) (ActionImpl a) +minimizeClassifier rules = minimizeShadowing fst rules + +{-| Each rule of the intermediate form is called a Bone. -} +data Bone ptrn actn = Bone ptrn Pattern actn + deriving (Show, Eq) + +{-| Skeletons are the intermediate form. -} +type Skeleton ptrn actn = [Bone ptrn actn] + +{-| Map the actions. |-} +skelMap :: (a -> b) -> Skeleton ptrn a -> Skeleton ptrn b +skelMap f bones = map (\(Bone ptrn pr actns) -> Bone ptrn pr (f actns)) bones + +{-| Cartesian combine two skeletons given a combination function for the actions. -} +skelCart :: FreneticImpl a + => (actn -> actn -> actn) + -> Skeleton (PatternImpl a) actn + -> Skeleton (PatternImpl a) actn + -> (Skeleton (PatternImpl a) actn, + Skeleton (PatternImpl a) actn, + Skeleton (PatternImpl a) actn) +skelCart f bs1 bs2 = + let + (bs1',bs2',bs3') = cartMap h [] bs1 bs2 + in + (bs1', bs2', bs3') + where + h bs x@(Bone ptrn1 iptrn1 actns1) y@(Bone ptrn2 iptrn2 actns2) = + case intersect ptrn1 ptrn2 of + Just ptrn12 -> + case intersect iptrn1 iptrn2 of + Just iptrn12 -> + (bs ++ [Bone ptrn12 iptrn12 (f actns1 actns2)], + if ptrn12 == ptrn1 then Nothing else Just x, + if ptrn12 == ptrn2 then Nothing else Just y) + Nothing -> error "skelCart: i-pattern intersection failed." + Nothing -> + (bs, Just x, Just y) + +{-| Attempt to reduce the number of rules in a Skeleton. -} +skelMinimize :: FreneticImpl a + => Skeleton (PatternImpl a) actn + -> Skeleton (PatternImpl a) actn +skelMinimize bones = minimizeShadowing getPat bones + where getPat (Bone p1 p2 as) = FreneticPat p2 + +{-| Compile a predicate to intermediate form. -} +compilePredicate :: FreneticImpl a + => Switch + -> Predicate + -> Skeleton (PatternImpl a) Bool +compilePredicate s (PrPattern pat) = [Bone (fromPattern pat) pat True] +compilePredicate s (PrTo s') | s == s' = [Bone top top True] + | otherwise = [] +compilePredicate s (PrIntersect pr1 pr2) = skelMinimize skel12' + where + skel1 = compilePredicate s pr1 + skel2 = compilePredicate s pr2 + (skel12', skel1', skel2') = skelCart (&&) skel1 skel2 +compilePredicate s (PrUnion pr1 pr2) = skelMinimize $ skel12' ++ skel1' ++ skel2' + where + skel1 = compilePredicate s pr1 + skel2 = compilePredicate s pr2 + (skel12', skel1', skel2') = skelCart (||) skel1 skel2 +compilePredicate s (PrNegate pr) = + skelMap not (compilePredicate s pr) ++ [Bone top top True] + +{-| Compile a policy to intermediate form -} +compilePolicy :: FreneticImpl a + => Switch -> Policy -> Skeleton (PatternImpl a) Action +compilePolicy _ PoBottom = [] +compilePolicy s (PoBasic po as) = + skelMap f $ compilePredicate s po + where f True = as + f False = dropPkt +compilePolicy s (PoUnion po1 po2) = + skelMinimize $ skel12' ++ skel1' ++ skel2' + where skel1 = compilePolicy s po1 + skel2 = compilePolicy s po2 + (skel12', skel1', skel2') = + skelCart (<+>) skel1 skel2 + +{-| Compile a policy to a classifier. -} +compile :: FreneticImpl a + => Switch + -> Policy + -> Classifier (PatternImpl a) (ActionImpl a) +compile s po = map f skel + where + f (Bone sptrn iptrn actn) + | toPattern sptrn `match` iptrn = (sptrn, actnTranslate actn) + | otherwise = (sptrn, actnController) + skel = compilePolicy s po + diff --git a/src/Frenetic/NetCore/Pretty.hs b/src/Frenetic/NetCore/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/NetCore/Pretty.hs @@ -0,0 +1,64 @@ +module Frenetic.NetCore.Pretty + ( toString + , putNetCore + , putNetCoreLn + , hPutNetCore + ) where + +import Data.List +import qualified Data.MultiSet as MS +import Frenetic.NetCore.Short +import Frenetic.NetCore.Types +import System.IO +import Text.PrettyPrint.ANSI.Leijen + +ribbonFrac = 0.8 +lineWidth = 100 + +render = renderPretty ribbonFrac lineWidth + +-- |Pretty-print a netcore policy to a String +toString p = displayS (render $ prettyPo p) "" + +-- |Pretty-print a netcore policy to stdout +putNetCore = hPutNetCore stdout +putNetCoreLn = hPutNetCoreLn stdout + +-- |Pretty-print a netcore policy to a handle +hPutNetCore :: Handle -> Policy -> IO () +hPutNetCore h p = do + let rendered = render $ prettyPo p + displayIO h rendered + +hPutNetCoreLn h p = do + hPutNetCore h p + hPutChar h '\n' + +prettyPr (PrPattern p) = prettyPattern " = " p +prettyPr (PrTo s) = text "switch = " <> integer (fromIntegral s) +prettyPr p@(PrUnion _ _) = text "Or " <> + (align . tupled . map prettyPr $ prUnUnion p) +prettyPr p@(PrIntersect _ _) = text "And " <> + (align . tupled . map prettyPr $ prUnIntersect p) +prettyPr (PrNegate p) = text "Not " <> align (tupled [prettyPr p]) + +prettyAc (Action fwds qs) = + (semiBraces . map prettyForward . MS.toAscList $ fwds) + text "emit " <> + (semiBraces . map (integer . fromIntegral . idOfQuery) . MS.toAscList $ qs) + +prettyPo PoBottom = text "Bottom" +prettyPo (PoBasic pr ac) = prettyPr pr text " ==> " <> align (prettyAc ac) +prettyPo p = list (map prettyPo (poUnUnion p)) -- safe because poUnUnion + +-- |Render patterns as "{fieldvalue; fieldvalue}" +prettyPattern sep p = semiBraces . map text . interesting sep $ p + +-- |Render a forwarding option as "port with {field := value; field := value}" +prettyForward (port, mods) = prettyPseudoPort port <> mods' where + mods' = if mods == unmodified then empty + else text " with " <> text (show mods) + +-- |Render a pseudoport as "Port p" or "Flood" +prettyPseudoPort (Physical p) = text "Port " <> integer (fromIntegral p) +prettyPseudoPort AllPorts = text "AllPorts" diff --git a/src/Frenetic/NetCore/Reduce.hs b/src/Frenetic/NetCore/Reduce.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/NetCore/Reduce.hs @@ -0,0 +1,48 @@ +module Frenetic.NetCore.Reduce + ( reduce + ) where + +import Frenetic.Common +import Data.Maybe +import qualified Data.MultiSet as MS +import qualified Data.Set as Set +import Frenetic.NetCore.Types +import Frenetic.NetCore.Short + +-- |Reduce the policy to produce a smaller, more readable policy +reduce = reducePo + +reducePo :: Policy -> Policy +reducePo PoBottom = PoBottom +reducePo (PoBasic pr act) = if pr' == matchNone || act == mempty + then PoBottom + else PoBasic pr' act' where + pr' = reducePr pr + act' = act +-- Note that because we use multiset forwarding semantics, we CANNOT do common +-- subexpression reduction on unions. +reducePo (PoUnion p1 p2) = if p1' == PoBottom then p2' + else if p2' == PoBottom then p1' + else PoUnion p1' p2' where + p1' = reducePo p1 + p2' = reducePo p2 + +-- TODO(astory): do reductions beyond common subexpression reduction. Ideas: +-- top reduction, bottom reduction, empty intersection reduction. +reducePr :: Predicate -> Predicate +reducePr p@(PrUnion _ _) = prOr leaves where + leaves = Set.toList . Set.fromList . map reducePr . prUnUnion $ p + +reducePr p@(PrIntersect _ _) = result where + leaves = Set.toList . Set.fromList . map reducePr . prUnIntersect $ p + nSwitches = Set.size .Set.fromList . mapMaybe switchOfPred $ leaves + result = if nSwitches > 1 then matchNone + else prAnd leaves + +reducePr (PrNegate (PrNegate p)) = reducePr p +reducePr (PrNegate p) = PrNegate (reducePr p) + +reducePr p = p + +switchOfPred (PrTo s) = Just s +switchOfPred _ = Nothing diff --git a/src/Frenetic/NetCore/Semantics.hs b/src/Frenetic/NetCore/Semantics.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/NetCore/Semantics.hs @@ -0,0 +1,85 @@ +-- |Composes NetCore policies and predicates, and defines how these policies +-- interpret abstract packets. +module Frenetic.NetCore.Semantics where + +import Frenetic.Compat +import Frenetic.Pattern +import Frenetic.Common +import Frenetic.NetCore.Types +import Frenetic.NetCore.Short +import qualified Data.MultiSet as MS + +-- |Implements the denotation function for predicates. +interpretPredicate :: FreneticImpl a + => Predicate + -> Transmission (PatternImpl a) (PacketImpl a) + -> Bool +interpretPredicate (PrPattern ptrn) tr = case toPacket (trPkt tr) of + Nothing -> False + Just pk -> FreneticPkt pk `ptrnMatchPkt` FreneticPat ptrn +interpretPredicate (PrTo sw) tr = + sw == trSwitch tr +interpretPredicate (PrUnion pr1 pr2) tr = + interpretPredicate pr1 tr || interpretPredicate pr2 tr +interpretPredicate (PrIntersect pr1 pr2) tr = + interpretPredicate pr1 tr && interpretPredicate pr2 tr +interpretPredicate (PrNegate pr) tr = + not (interpretPredicate pr tr) + +-- |Implements the denotation function for policies. +interpretPolicy :: FreneticImpl a + => Policy + -> Transmission (PatternImpl a) (PacketImpl a) + -> Action +interpretPolicy PoBottom tr = dropPkt +interpretPolicy (PoBasic pred acts) tr = + if interpretPredicate pred tr then acts else dropPkt +interpretPolicy (PoUnion p1 p2) tr = + interpretPolicy p1 tr <+> interpretPolicy p2 tr + +instance Matchable (PatternImpl ()) where + top = FreneticPat top + intersect (FreneticPat p1) (FreneticPat p2) = case intersect p1 p2 of + Just p3 -> Just (FreneticPat p3) + Nothing -> Nothing +-- | +instance FreneticImpl () where + data PacketImpl () = FreneticPkt Packet deriving (Show, Eq) + data PatternImpl () = FreneticPat Pattern deriving (Show, Eq) + data ActionImpl () = FreneticAct { fromFreneticAct :: Action } + deriving (Show, Eq) + + toPacket (FreneticPkt x) = Just x + updatePacket pkt1 pkt2 = FreneticPkt pkt2 + ptrnMatchPkt (FreneticPkt pkt) (FreneticPat ptrn) = + wMatch (pktDlSrc pkt) (ptrnDlSrc ptrn) + && wMatch (pktDlDst pkt) (ptrnDlDst ptrn) + && wMatch (pktDlTyp pkt) (ptrnDlTyp ptrn) + && wMatch (pktDlVlan pkt) (ptrnDlVlan ptrn) + && wMatch (pktDlVlanPcp pkt) (ptrnDlVlanPcp ptrn) + && (case (pktNwSrc pkt, ptrnNwSrc ptrn) of + (Nothing, Prefix _ len) -> len == 0 + (Just addr, prefix) -> match (Prefix addr 32) prefix) + && (case (pktNwDst pkt, ptrnNwDst ptrn) of + (Nothing, Prefix _ len) -> len == 0 + (Just addr, prefix) -> match (Prefix addr 32) prefix) + && wMatch (pktNwProto pkt) (ptrnNwProto ptrn) + && wMatch (pktNwTos pkt) (ptrnNwTos ptrn) + && (case (pktTpSrc pkt, ptrnTpSrc ptrn) of + (Nothing, Wildcard) -> True + (Nothing, Exact _) -> False + (Just pt, pat) -> wMatch pt pat) + && (case (pktTpDst pkt, ptrnTpDst ptrn) of + (Nothing, Wildcard) -> True + (Nothing, Exact _) -> False + (Just pt, pat) -> wMatch pt pat) + && wMatch (pktInPort pkt) (ptrnInPort ptrn) + fromPattern pat = FreneticPat pat + toPattern (FreneticPat x) = x + actnDefault = FreneticAct dropPkt + actnController = FreneticAct dropPkt + actnTranslate x = FreneticAct x + actnControllerPart (FreneticAct (Action _ queries)) switchID + (FreneticPkt pkt) = do + let pktChans = map pktQueryChan . filter isPktQuery $ MS.toList queries + mapM_ (\chan -> writeChan chan (switchID, pkt)) pktChans diff --git a/src/Frenetic/NetCore/Short.hs b/src/Frenetic/NetCore/Short.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/NetCore/Short.hs @@ -0,0 +1,214 @@ +module Frenetic.NetCore.Short + ( -- * Shorthand constructors + -- ** Predicates + inport + , (<||>) + , (<&&>) + , matchAll + , matchNone + , neg + , prSubtract + , prOr + , prAnd + -- ** Actions + , dropPkt + , allPorts + , forward + , modify + -- ** Policies + , (==>) + , (<%>) + , (<+>) + -- * Exact match predicate constructors + , onSwitch + , dlSrc + , dlDst + , dlTyp + , dlVlan + , dlNoVlan + , dlVlanPcp + , nwSrc + , nwDst + , nwSrcPrefix + , nwDstPrefix + , nwProto + , nwTos + , tpSrc + , tpDst + , inPort + -- * Packet modifications + , Modification (..) + , unmodified + , modDlSrc + , modDlDst + , modDlVlan + , modDlVlanPcp + , modNwSrc + , modNwDst + , modNwTos + , modTpSrc + , modTpDst + ) where + +import Data.Word +import qualified Data.List as List +import qualified Data.MultiSet as MS +import Frenetic.Pattern +import Frenetic.NetCore.Types +import Data.Monoid + +-- |Matches all packets. +matchAll :: Predicate +matchAll = top + +-- |Matches no packets. +matchNone :: Predicate +matchNone = PrNegate top + +-- |Construct the predicate matching packets on this switch and port +inport :: Switch -> Port -> Predicate +inport switch port = PrIntersect (PrTo switch) + (PrPattern (top {ptrnInPort = Exact port})) + +-- |Construct the set difference between p1 and p2 +prSubtract :: Predicate -> Predicate -> Predicate +prSubtract p1 p2 = PrIntersect p1 (PrNegate p2) + +-- |Construct nary union of a list of predicates +prOr :: [Predicate] -> Predicate +prOr [] = neg top +prOr ps = List.foldr1 (\ p1 p2 -> PrUnion p1 p2) ps + +-- |Construct nary intersection of a list of predicates +prAnd :: [Predicate] -> Predicate +prAnd [] = top +prAnd ps = List.foldr1 (\ p1 p2 -> PrIntersect p1 p2) ps + +dropPkt :: Action +dropPkt = Action MS.empty MS.empty + +-- |Forward the packet out of all physical ports, except the packet's +-- ingress port. +allPorts :: Modification -- ^modifications to apply to the packet. Use + -- 'allPorts unmodified' to make no modifications. + -> Action +allPorts mod = Action (MS.singleton (AllPorts, mod)) MS.empty + +-- |Forward the packet out of the specified physical ports. +forward :: [Port] -> Action +forward ports = Action (MS.fromList lst) MS.empty + where lst = [ (Physical p, unmodified) | p <- ports ] + +-- |Forward the packet out of the specified physical ports with modifications. +-- +-- Each port has its own record of modifications, so modifications at one port +-- do not interfere with modifications at another port. +modify :: [(Port, Modification)] -> Action +modify mods = Action (MS.fromList lst) MS.empty + where lst = [ (Physical p, mod) | (p, mod) <- mods ] + +-- |Match switch identifier. +onSwitch = PrTo + +instance Monoid Action where + mappend (Action fwd1 q1) (Action fwd2 q2) = + Action (fwd1 `MS.union` fwd2) (q1 `MS.union` q2) + mempty = dropPkt + +-- |Join: overloaded to find the union of policies and the join of actions. +(<+>) :: Monoid a => a -> a -> a +(<+>) = mappend + +-- |Abbreviation for predicate union. +(<||>) = PrUnion + +-- |Abbreviation for predicate intersection. +(<&&>) = PrIntersect + +-- |Abbreviation for predicate negation. +neg = PrNegate + +-- |Abbreviation for constructing a basic policy from a predicate and an action. +(==>) = PoBasic + +-- |Restrict a policy to act over packets matching the predicate. +policy <%> pred = case policy of + PoBottom -> PoBottom + PoBasic predicate act -> PoBasic (PrIntersect predicate pred) act + PoUnion p1 p2 -> PoUnion (p1 <%> pred) (p2 <%> pred) + +instance Monoid Policy where + mappend = PoUnion + mempty = PoBottom + +-- |Match ethernet source address. +dlSrc :: Word48 -> Predicate +dlSrc value = PrPattern (top {ptrnDlSrc = Exact value}) + +-- |Match ethernet destination address. +dlDst :: Word48 -> Predicate +dlDst value = PrPattern (top {ptrnDlDst = Exact value}) + +-- |Match ethernet type code (e.g., 0x0800 for IP packets). +dlTyp :: Word16 -> Predicate +dlTyp value = PrPattern (top {ptrnDlTyp = Exact value}) + +-- |Match VLAN tag. +dlVlan :: Word16 -> Predicate +dlVlan value = PrPattern (top {ptrnDlVlan = Exact (Just value)}) + +-- |Match Vlan untagged +dlNoVlan :: Predicate +dlNoVlan = PrPattern (top {ptrnDlVlan = Exact Nothing}) + +-- |Match VLAN priority +dlVlanPcp :: Word8 -> Predicate +dlVlanPcp value = PrPattern (top {ptrnDlVlanPcp = Exact value}) + +-- |Match source IP address. +-- +-- This is only meaningful in combination with 'dlTyp 0x0800'. +nwSrc :: Word32 -> Predicate +nwSrc value = PrPattern (top {ptrnNwSrc = Prefix value 32}) + +-- |Match destination IP address. +nwDst :: Word32 -> Predicate +nwDst value = PrPattern (top {ptrnNwDst = Prefix value 32}) + +-- |Match a prefix of the source IP address. +nwSrcPrefix :: Word32 -> Int -> Predicate +nwSrcPrefix value prefix = PrPattern (top {ptrnNwSrc = Prefix value prefix}) + +-- |Match a prefix of the destination IP address. +nwDstPrefix :: Word32 -> Int -> Predicate +nwDstPrefix value prefix = PrPattern (top {ptrnNwDst = Prefix value prefix}) + +-- |Match IP protocol code (e.g., 0x6 indicates TCP segments). +nwProto :: Word8 -> Predicate +nwProto value = PrPattern (top {ptrnNwProto = Exact value}) + +-- |Match IP TOS field. +nwTos :: Word8 -> Predicate +nwTos value = PrPattern (top {ptrnNwTos = Exact value}) + +-- |Match IP source port. +tpSrc :: Word16 -> Predicate +tpSrc value = PrPattern (top {ptrnTpSrc = Exact value}) + +-- |Match IP destination port. +tpDst :: Word16 -> Predicate +tpDst value = PrPattern (top {ptrnTpDst = Exact value}) + +-- |Match the ingress port on which packets arrive. +inPort :: Port -> Predicate +inPort value = PrPattern (top {ptrnInPort = Exact value}) + +modDlSrc value = unmodified {modifyDlSrc = Just value} +modDlDst value = unmodified {modifyDlDst = Just value} +modDlVlan value = unmodified {modifyDlVlan = Just value} +modDlVlanPcp value = unmodified {modifyDlVlanPcp = Just value} +modNwSrc value = unmodified {modifyNwSrc = Just value} +modNwDst value = unmodified {modifyNwDst = Just value} +modNwTos value = unmodified {modifyNwTos = Just value} +modTpSrc value = unmodified {modifyTpSrc = Just value} +modTpDst value = unmodified {modifyTpDst = Just value} diff --git a/src/Frenetic/NetCore/Types.hs b/src/Frenetic/NetCore/Types.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/NetCore/Types.hs @@ -0,0 +1,397 @@ +module Frenetic.NetCore.Types + ( -- * Basic types + Switch + , Port + , Vlan + , Loc (..) + , PseudoPort (..) + , Word48 + -- * Actions + , Action (..) + , Query (..) + , Counter (..) + , Modification (..) + , unmodified + , isPktQuery + -- ** Basic actions + , countPkts + , countBytes + , getPkts + -- ** Inspecting actions + , actionForwardsTo + -- * Patterns + , Pattern (..) + -- * Predicates + , Predicate (..) + , exactMatch + -- * Packets + , Packet (..) + -- * Policies + , Policy (..) + -- * Tools + , interesting + , modifiedFields + , prUnIntersect + , prUnUnion + , poUnUnion + , poDom + , module Frenetic.EthernetAddress + , size + ) where + +import Frenetic.Common +import Data.Bits +import Data.IORef +import qualified Data.List as List +import qualified Data.MultiSet as MS +import qualified Data.Set as Set +import Data.Word +import Frenetic.Pattern +import System.IO.Unsafe +import Data.Maybe (catMaybes) +import Frenetic.EthernetAddress + +-- |A switch's unique identifier. +type Switch = Word64 + +-- |The number of a physical port. +type Port = Word16 + +-- |'Loc' uniquely identifies a port at a switch. +data Loc = Loc Switch Port + deriving (Eq, Ord, Show) + +-- |Logical ports. +data PseudoPort + = Physical Port + | AllPorts + deriving (Eq, Ord, Show) + +-- |VLAN tags. Only the lower 12-bits are used. +type Vlan = Word16 + + +-- |Ethernet addresses are 48-bits wide. +type Word48 = EthernetAddress + +-- |Packets' headers. +data Packet = Packet { + pktDlSrc :: Word48, -- ^source ethernet address + pktDlDst :: Word48, -- ^destination ethernet address + pktDlTyp :: Word16, -- ^ethernet type code (e.g., 0x800 for IP packets) + pktDlVlan :: Maybe Vlan, -- ^VLAN tag + pktDlVlanPcp :: Word8, -- ^VLAN priority code + pktNwSrc :: Maybe Word32, -- ^source IP address for IP packets + pktNwDst :: Maybe Word32, -- ^destination IP address for IP packets + pktNwProto :: Word8, -- ^IP protocol number (e.g., 6 for TCP segments) + pktNwTos :: Word8, -- ^IP TOS field + pktTpSrc :: Maybe Word16, -- ^source port for IP packets + pktTpDst :: Maybe Word16, -- ^destination port for IP packets + pktInPort :: Port -- ^ingress port on the switch where the packet was + -- received +} deriving (Show, Eq, Ord) + +-- |Patterns to match packets. Patterns translate directly to a single OpenFlow +-- match rule. +data Pattern = Pattern { + ptrnDlSrc :: Wildcard Word48 + , ptrnDlDst :: Wildcard Word48 + , ptrnDlTyp :: Wildcard Word16 + , ptrnDlVlan :: Wildcard (Maybe Vlan) + , ptrnDlVlanPcp :: Wildcard Word8 + , ptrnNwSrc :: Prefix Word32 + , ptrnNwDst :: Prefix Word32 + , ptrnNwProto :: Wildcard Word8 + , ptrnNwTos :: Wildcard Word8 + , ptrnTpSrc :: Wildcard Word16 + , ptrnTpDst :: Wildcard Word16 + , ptrnInPort :: Wildcard Port + } deriving (Ord, Eq) + +-- |Predicates to match packets. +data Predicate + = PrPattern Pattern -- ^Match with a simple pattern. + | PrTo Switch -- ^Match only at this switch. + | PrUnion Predicate Predicate -- ^Match either predicates. + | PrIntersect Predicate Predicate -- ^Match both predicates. + | PrNegate Predicate -- ^PrNegate P matches packets that do not match P. + deriving (Eq, Ord) + +-- |Names of common header fields. +data Field + = DlSrc | DlDst | DlVlan | DlVlanPcp | NwSrc | NwDst | NwTos | TpSrc | TpDst + deriving (Eq, Ord, Show) + +-- |For each fields with a value Just v, modify that field to be v. +-- If the field is Nothing then there is no modification of that field. +data Modification = Modification { + modifyDlSrc :: Maybe Word48, + modifyDlDst :: Maybe Word48, + modifyDlVlan :: Maybe (Maybe Vlan), + modifyDlVlanPcp :: Maybe Word8, + modifyNwSrc :: Maybe Word32, + modifyNwDst :: Maybe Word32, + modifyNwTos :: Maybe Word8, + modifyTpSrc :: Maybe Word16, + modifyTpDst :: Maybe Word16 +} deriving (Ord, Eq, Show) + +-- |A predicate that exactly matches a packet's headers. +exactMatch :: Packet -> Predicate +exactMatch (Packet{..}) = PrPattern pat + where pat = Pattern (Exact pktDlSrc) (Exact pktDlDst) (Exact pktDlTyp) + (Exact pktDlVlan) (Exact pktDlVlanPcp) + (prefix pktNwSrc) (prefix pktNwDst) + (Exact pktNwProto) + (Exact pktNwTos) (exact pktTpSrc) (exact pktTpDst) + (Exact pktInPort) + prefix Nothing = Prefix 0 0 + prefix (Just v) = Prefix v 32 + exact Nothing = Wildcard + exact (Just v) = Exact v + +unmodified :: Modification +unmodified = Modification Nothing Nothing Nothing Nothing Nothing Nothing + Nothing Nothing Nothing + +modifiedFields :: Modification -> Set Field +modifiedFields (Modification{..}) = Set.fromList (catMaybes fields) where + fields = [ case modifyDlSrc of { Just _ -> Just DlSrc; Nothing -> Nothing } + , case modifyDlDst of { Just _ -> Just DlDst; Nothing -> Nothing } + , case modifyDlVlan of { Just _ -> Just DlVlan; Nothing -> Nothing } + , case modifyDlVlanPcp of { Just _ -> Just DlVlanPcp; + Nothing -> Nothing } + , case modifyNwSrc of { Just _ -> Just NwSrc; Nothing -> Nothing } + , case modifyNwDst of { Just _ -> Just NwDst; Nothing -> Nothing } + , case modifyNwTos of { Just _ -> Just NwTos; Nothing -> Nothing } + , case modifyTpSrc of { Just _ -> Just TpSrc; Nothing -> Nothing } + , case modifyTpDst of { Just _ -> Just TpDst; Nothing -> Nothing } + ] + + +instance Matchable Pattern where + top = Pattern { + ptrnDlSrc = top + , ptrnDlDst = top + , ptrnDlTyp = top + , ptrnDlVlan = top + , ptrnDlVlanPcp = top + , ptrnNwSrc = top + , ptrnNwDst = top + , ptrnNwProto = top + , ptrnNwTos = top + , ptrnTpSrc = top + , ptrnTpDst = top + , ptrnInPort = top + } + + intersect p1 p2 = do ptrnDlSrc' <- intersect (ptrnDlSrc p1) (ptrnDlSrc p2) + ptrnDlDst' <- intersect (ptrnDlDst p1) (ptrnDlDst p2) + ptrnDlTyp' <- intersect (ptrnDlTyp p1) (ptrnDlTyp p2) + ptrnDlVlan' <- intersect (ptrnDlVlan p1) (ptrnDlVlan p2) + ptrnDlVlanPcp' <- intersect (ptrnDlVlanPcp p1) (ptrnDlVlanPcp p2) + ptrnNwSrc' <- intersect (ptrnNwSrc p1) (ptrnNwSrc p2) + ptrnNwDst' <- intersect (ptrnNwDst p1) (ptrnNwDst p2) + ptrnNwProto' <- intersect (ptrnNwProto p1) (ptrnNwProto p2) + ptrnNwTos' <- intersect (ptrnNwTos p1) (ptrnNwTos p2) + ptrnTpSrc' <- intersect (ptrnTpSrc p1) (ptrnTpSrc p2) + ptrnTpDst' <- intersect (ptrnTpDst p1) (ptrnTpDst p2) + ptrnInPort' <- intersect (ptrnInPort p1) (ptrnInPort p2) + return Pattern { + ptrnDlSrc = ptrnDlSrc' + , ptrnDlDst = ptrnDlDst' + , ptrnDlTyp = ptrnDlTyp' + , ptrnDlVlan = ptrnDlVlan' + , ptrnDlVlanPcp = ptrnDlVlanPcp' + , ptrnNwSrc = ptrnNwSrc' + , ptrnNwDst = ptrnNwDst' + , ptrnNwProto = ptrnNwProto' + , ptrnNwTos = ptrnNwTos' + , ptrnTpSrc = ptrnTpSrc' + , ptrnTpDst = ptrnTpDst' + , ptrnInPort = ptrnInPort' + } + +instance Show Pattern where + show p = "{" ++ contents ++ "}" where + contents = concat (List.intersperse ", " (interesting " = " p)) + +-- |Build a list of the non-wildcarded patterns with sep between field and value +interesting :: String -> Pattern -> [String] +interesting sep (Pattern {..}) = filter (/= "") lines where + lines = [ case ptrnDlSrc of {Exact v -> "DlSrc" ++ sep ++ show v; Wildcard -> ""} + , case ptrnDlDst of {Exact v -> "DlDst" ++ sep ++ show v; Wildcard -> ""} + , case ptrnDlTyp of {Exact v -> "DlTyp" ++ sep ++ show v; Wildcard -> ""} + , case ptrnDlVlan of {Exact v -> "DlVlan" ++ sep ++ show v; Wildcard -> ""} + , case ptrnDlVlanPcp of {Exact v -> "DlVlanPcp" ++ sep ++ show v; Wildcard -> ""} + , case ptrnNwSrc of {Prefix _ 0 -> ""; p -> "NwSrc" ++ sep ++ show p} + , case ptrnNwDst of {Prefix _ 0 -> ""; p -> "NwDst" ++ sep ++ show p} + , case ptrnNwProto of {Exact v -> "NwProto" ++ sep ++ show v; Wildcard -> ""} + , case ptrnNwTos of {Exact v -> "NwTos" ++ sep ++ show v; Wildcard -> ""} + , case ptrnTpSrc of {Exact v -> "TpSrc" ++ sep ++ show v; Wildcard -> ""} + , case ptrnTpDst of {Exact v -> "TpDst" ++ sep ++ show v; Wildcard -> ""} + , case ptrnInPort of {Exact v -> "InPort" ++ sep ++ show v; Wildcard -> ""} + ] + +type QueryID = Int + +nextQueryID :: IORef QueryID +nextQueryID = unsafePerformIO $ newIORef 0 + +getNextQueryID :: IO QueryID +getNextQueryID = atomicModifyIORef nextQueryID (\i -> (i + 1, i)) + +data Counter = CountPackets | CountBytes deriving (Eq, Ord) + +data Query + = NumPktQuery { + idOfQuery :: QueryID, + numPktQueryChan :: Chan (Switch, Integer), + queryInterval :: Int, + countField :: Counter, + totalVal :: IORef Integer, + lastVal :: IORef Integer + } + | PktQuery { + pktQueryChan :: Chan (Switch, Packet), + idOfQuery :: QueryID + } + deriving (Eq) + +-- |Actions to perform on packets. +data Action = Action { + actionForwards :: MS.MultiSet (PseudoPort, Modification), + actionQueries :: MS.MultiSet Query +} deriving (Eq, Ord) + +isPktQuery (PktQuery _ _) = True +isPktQuery _ = False + +actionForwardsTo :: Action -> MS.MultiSet PseudoPort +actionForwardsTo (Action m _) = + MS.map fst m + +mkCountQuery :: Counter -> Int -> IO (Chan (Switch, Integer), Action) +mkCountQuery counter millisecondInterval = do + ch <- newChan + queryID <- getNextQueryID + total <- newIORef 0 + last <- newIORef 0 + let q = NumPktQuery queryID ch millisecondInterval counter total last + return (ch, Action MS.empty (MS.singleton q)) + + +-- ^Periodically polls the network to counts the number of packets received. +-- +-- Returns an 'Action' and a channel. When the 'Action' is used in the +-- active 'Policy', the controller periodically reads the packet counters +-- on the network. The controller returns the number of matching packets +-- on each switch. +countPkts :: Int -- ^polling interval, in milliseconds + -> IO (Chan (Switch, Integer), Action) +countPkts = mkCountQuery CountPackets + +-- ^Periodically polls the network to counts the number of bytes received. +-- +-- Returns an 'Action' and a channel. When the 'Action' is used in the +-- active 'Policy', the controller periodically reads the packet counters +-- on the network. The controller returns the number of matching packets +-- on each switch. +countBytes :: Int -- ^polling interval, in milliseconds + -> IO (Chan (Switch, Integer), Action) +countBytes = mkCountQuery CountBytes + + +-- ^Sends packets to the controller. +-- +-- Returns an 'Action' and a channel. When the 'Action' is used in the active +-- 'Policy', all matching packets are sent to the controller. These packets +-- are written into the channel. +getPkts :: IO (Chan (Switch, Packet), Action) +getPkts = do + ch <- newChan + queryID <- getNextQueryID + let q = PktQuery ch queryID + return (ch, Action MS.empty (MS.singleton q)) + +-- |Get back all predicates in the intersection. Does not return any naked +-- intersections. +prUnIntersect :: Predicate -> [Predicate] +prUnIntersect po = List.unfoldr f [po] where + f predicates = case predicates of + [] -> Nothing + (PrIntersect p1 p2) : rest -> f (p1 : (p2 : rest)) + p : rest -> Just (p, rest) + +-- |Get back all predicates in the union. Does not return any naked unions. +prUnUnion :: Predicate -> [Predicate] +prUnUnion po = List.unfoldr f [po] where + f predicates = case predicates of + [] -> Nothing + (PrUnion p1 p2) : rest -> f (p1 : (p2 : rest)) + p : rest -> Just (p, rest) + +{-| Policies denote functions from (switch, packet) to packets. -} +data Policy + = PoBottom -- ^Performs no actions. + | PoBasic Predicate Action -- ^Performs the given action on packets matching the given predicate. + | PoUnion Policy Policy -- ^Performs the actions of both P1 and P2. + deriving (Eq, Ord) + +instance Show Predicate where + show (PrPattern pat) = show pat + show (PrTo s) = "switch(" ++ show s ++ ")" + show (PrUnion pr1 pr2) = "(" ++ show pr1 ++ ") \\/ (" ++ show pr2 ++ ")" + show (PrIntersect pr1 pr2) = "(" ++ show pr1 ++ ") /\\ (" ++ show pr2 ++ ")" + show (PrNegate pr) = "~(" ++ show pr ++ ")" + +instance Matchable Predicate where + top = PrPattern top + intersect p1 p2 = Just (PrIntersect p1 p2) + +instance Ord Query where + compare q1 q2 = compare qid1 qid2 where + qid1 = idOfQuery q1 + qid2 = idOfQuery q2 + +instance Show Action where + show (Action fwd q) = "" + +instance Show Query where + show (NumPktQuery{..}) = + "countPkts(interval=" ++ show queryInterval ++ "ms, id=" ++ + show idOfQuery ++ ")" + show (PktQuery{..}) = "getPkts(id=" ++ show idOfQuery ++ ")" + +instance Show Policy where + show PoBottom = "(PoBottom)" + show (PoBasic pr as) = "(" ++ show pr ++ ") -> " ++ show as + show (PoUnion po1 po2) = "(" ++ show po1 ++ ") \\/ (" ++ show po2 ++ ")" + +-- |Get back all basic policies in the union. Does not return any unions. +poUnUnion :: Policy -> [Policy] +poUnUnion po = List.unfoldr f [po] where + f policies = case policies of + [] -> Nothing + (PoUnion p1 p2) : rest -> f (p1 : (p2 : rest)) + p : rest -> Just (p, rest) + +-- |Returns a predicate that matches the domain of the policy. +poDom :: Policy -> Predicate +poDom PoBottom = PrNegate top +poDom (PoBasic pred _) = pred +poDom (PoUnion pol1 pol2) = PrUnion (poDom pol1) (poDom pol2) + +-- |Returns the approximate size of the policy +size :: Policy -> Int +size PoBottom = 1 +size (PoBasic p _) = prSize p + 1 +size (PoUnion p1 p2) = size p1 + size p2 + 1 + +-- |Returns the approximate size of the predicate +prSize :: Predicate -> Int +prSize (PrPattern _) = 1 +prSize (PrTo _) = 1 +prSize (PrUnion p1 p2) = prSize p1 + prSize p2 + 1 +prSize (PrIntersect p1 p2) = prSize p1 + prSize p2 + 1 +prSize (PrNegate p) = prSize p + 1 diff --git a/src/Frenetic/NettleEx.hs b/src/Frenetic/NettleEx.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/NettleEx.hs @@ -0,0 +1,197 @@ +-- |Nettle with additional features. None of this code is Frenetic-specific. +module Frenetic.NettleEx + ( Nettle + , sendTransaction + , module Nettle.OpenFlow + , module Nettle.Servers.Server + , closeServer + , acceptSwitch + , sendToSwitch + , sendToSwitchWithID + , startOpenFlowServerEx + , ethVLANId + , ethVLANPcp + , ethSrcIP + , ethDstIP + , ethProto + , ethTOS + , srcPort + , dstPort + ) where + +import Frenetic.Common +import qualified Data.Map as Map +import Nettle.OpenFlow hiding (intersect) +import qualified Nettle.Servers.Server as Server +import Nettle.Servers.Server hiding (acceptSwitch, closeServer, sendToSwitch, + sendToSwitchWithID) +import Nettle.Ethernet.EthernetFrame +import Nettle.Ethernet.AddressResolutionProtocol +import Prelude hiding (catch) +import Control.Exception + +data Nettle = Nettle { + server :: OpenFlowServer, + switches :: IORef (Map SwitchID SwitchHandle), + nextTxId :: IORef TransactionID, + -- ^ Transaction IDs in the semi-open interval '[0, nextTxId)' are in use. + -- @sendTransaction@ tries to reserve 'nextTxId' atomically. There could be + -- available transaction IDs within the range, but we will miss them + -- until 'nextTxId' changes. + txHandlers :: IORef (Map TransactionID (SCMessage -> IO ())) +} + +startOpenFlowServerEx :: Maybe HostName -> ServerPortNumber -> IO Nettle +startOpenFlowServerEx host port = do + server <- Server.startOpenFlowServer Nothing -- bind to this address + 6633 -- port to listen on + switches <- newIORef Map.empty + nextTxId <- newIORef 10 + txHandlers <- newIORef Map.empty + return (Nettle server switches nextTxId txHandlers) + +acceptSwitch :: Nettle + -> IO (SwitchHandle, + SwitchFeatures, + Chan (TransactionID, SCMessage)) +acceptSwitch nettle = do + let exnHandler (e :: SomeException) = do + infoM "nettle" $ "could not accept switch " ++ show e + accept + accept = do + (Server.acceptSwitch (server nettle)) `catches` + [ Handler (\(e :: AsyncException) -> throw e), + Handler exnHandler ] + (switch, switchFeatures) <- accept + modifyIORef (switches nettle) (Map.insert (handle2SwitchID switch) switch) + switchMessages <- newChan + let loop = do + m <- receiveFromSwitch switch + case m of + Nothing -> return () + Just (xid, msg) -> do + handlers <- readIORef (txHandlers nettle) + debugM "nettle" $ "received message xid=" ++ show xid + case Map.lookup xid handlers of + Just handler -> handler msg + Nothing -> writeChan switchMessages (xid, msg) + threadId <- forkIO $ forever loop + return (switch, switchFeatures, switchMessages) + +closeServer :: Nettle -> IO () +closeServer nettle = Server.closeServer (server nettle) + +sendToSwitch :: SwitchHandle -> (TransactionID, CSMessage) -> IO () +sendToSwitch sw (xid, msg) = do + debugM "nettle" $ "msg to switch with xid=" ++ show xid ++ "; msg=" ++ + show msg + Server.sendToSwitch sw (xid, msg) + +sendToSwitchWithID :: Nettle -> SwitchID -> (TransactionID, CSMessage) -> IO () +sendToSwitchWithID nettle sw (xid, msg) = do + debugM "nettle" $ "msg to switch with xid=" ++ show xid ++ "; msg=" ++ + show msg + Server.sendToSwitchWithID (server nettle) sw (xid, msg) + + + +-- |spin-lock until we acquire a 'TransactionID' +reserveTxId :: Nettle -> IO TransactionID +reserveTxId nettle@(Nettle _ _ nextTxId _) = do + let getNoWrap n = case n == maxBound of + False -> (n + 1, Just n) + True -> (n, Nothing) + r <- atomicModifyIORef nextTxId getNoWrap + case r of + Just n -> return n + Nothing -> reserveTxId nettle + +releaseTxId :: TransactionID -> Nettle -> IO () +releaseTxId n (Nettle _ _ nextTxId _) = do + let release m = case m == n of + False -> (m, ()) + True -> (m - 1, ()) + atomicModifyIORef nextTxId release + +csMsgWithResponse :: CSMessage -> Bool +csMsgWithResponse msg = case msg of + CSHello -> True + CSEchoRequest _ -> True + FeaturesRequest -> True + StatsRequest _ -> True + BarrierRequest -> True + GetQueueConfig _ -> True + otherwise -> False + +hasMoreReplies :: SCMessage -> Bool +hasMoreReplies msg = case msg of + StatsReply (FlowStatsReply True _) -> True + StatsReply (TableStatsReply True _) -> True + StatsReply (PortStatsReply True _) -> True + StatsReply (QueueStatsReply True _) -> True + otherwise -> False + +sendTransaction :: Nettle + -> SwitchHandle -- ^target switch + -> [CSMessage] -- ^related messages + -> ([SCMessage] -> IO ()) -- ^callback + -> IO () +sendTransaction nettle@(Nettle _ _ _ txHandlers) sw reqs callback = do + txId <- reserveTxId nettle + resps <- newIORef ([] :: [SCMessage]) + remainingResps <- newIORef (length (filter csMsgWithResponse reqs)) + let handler msg = do + modifyIORef resps (msg:) -- Nettle client operates in one thread + unless (hasMoreReplies msg) $ do + modifyIORef remainingResps (\x -> x - 1) + n <- readIORef remainingResps + when (n == 0) $ do + resps <- readIORef resps + atomicModifyIORef txHandlers (\hs -> (Map.delete txId hs, ())) + releaseTxId txId nettle + callback resps + atomicModifyIORef txHandlers (\hs -> (Map.insert txId handler hs, ())) + mapM_ (sendToSwitch sw) (zip (repeat txId) reqs) + return () + +ethVLANId :: EthernetHeader -> Maybe VLANID +ethVLANId (Ethernet8021Q _ _ _ _ _ vlanId) = Just vlanId +ethVLANId (EthernetHeader {}) = Nothing + +ethVLANPcp :: EthernetHeader -> VLANPriority +ethVLANPcp (EthernetHeader _ _ _) = 0 +ethVLANPcp (Ethernet8021Q _ _ _ pri _ _) = pri + +stripIP (IPAddress a) = a + +ethSrcIP (IPInEthernet (HCons hdr _)) = Just (stripIP (ipSrcAddress hdr)) +ethSrcIP (ARPInEthernet (ARPQuery q)) = Just (stripIP (querySenderIPAddress q)) +ethSrcIP (ARPInEthernet (ARPReply r)) = Just (stripIP (replySenderIPAddress r)) +ethSrcIP (UninterpretedEthernetBody _) = Nothing + +ethDstIP (IPInEthernet (HCons hdr _)) = Just (stripIP (ipDstAddress hdr)) +ethDstIP (ARPInEthernet (ARPQuery q)) = Just (stripIP (queryTargetIPAddress q)) +ethDstIP (ARPInEthernet (ARPReply r)) = Just (stripIP (replyTargetIPAddress r)) +ethDstIP (UninterpretedEthernetBody _) = Nothing + +ethProto (IPInEthernet (HCons hdr _)) = Just (ipProtocol hdr) +ethProto (ARPInEthernet (ARPQuery _)) = Just 1 +ethProto (ARPInEthernet (ARPReply _)) = Just 2 +ethProto (UninterpretedEthernetBody _) = Nothing + +ethTOS (IPInEthernet (HCons hdr _)) = Just (dscp hdr) +ethTOS _ = Just 0 + +srcPort (IPInEthernet (HCons _ (HCons pk _))) = case pk of + TCPInIP (src, dst) -> Just src + UDPInIP (src, dst) _ -> Just src + ICMPInIP (typ, cod) -> Just (fromIntegral typ) + UninterpretedIPBody _ -> Nothing +srcPort _ = Nothing + +dstPort (IPInEthernet (HCons _ (HCons pk _))) = case pk of + TCPInIP (src, dst) -> Just dst + UDPInIP (src, dst) _ -> Just dst + ICMPInIP (typ, cod) -> Just (fromIntegral cod) + UninterpretedIPBody _ -> Nothing +dstPort _ = Nothing diff --git a/src/Frenetic/NetworkFrames.hs b/src/Frenetic/NetworkFrames.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/NetworkFrames.hs @@ -0,0 +1,36 @@ +module Frenetic.NetworkFrames + ( arpReply + ) where + +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Frenetic.Common +import Frenetic.NetCore.Types + +arpReply :: Word48 -> Word32 -> Word48 -> Word32 -> ByteString +arpReply srcEth srcIP dstEth dstIP = + runPut $ putArpReply srcEth srcIP dstEth dstIP + +putArpReply :: Word48 + -> Word32 + -> Word48 + -> Word32 + -> Put +putArpReply srcEth srcIP dstEth dstIP = do + putEthPacket srcEth dstEth 0x0806 + putWord16be 1 -- ethernet header type + putWord16be 0x0800 + putWord8 6 -- bytes in MAC address + putWord8 4 -- bytes in IP address + putWord16be 2 -- reply + put srcEth + put srcIP + put dstEth + put dstIP + +putEthPacket :: Word48 -> Word48 -> Word16 -> Put +putEthPacket srcMac dstMac ethType = do + put dstMac + put srcMac + put ethType diff --git a/src/Frenetic/Pattern.hs b/src/Frenetic/Pattern.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/Pattern.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE + GeneralizedNewtypeDeriving #-} +module Frenetic.Pattern + ( Matchable (..) + , Wildcard (..) + , Prefix (..) + , wMatch + ) where + +import Data.List hiding (intersect) +import Data.Bits +import Data.Word +import Data.Maybe +import Numeric (showHex) + +{-| +A class for types that compose similar to wildcards. + +All instances must satisfy the following: + +* @match@ defines a partial order; @top@ is the top element of this order + and @intersect@ is a meet. + +* Meets are exact: if @match x y@ and @match x z@, then + @match x (fromJust (intersect y z))@, if such a meet exists. + +Minimal complete definition: top and intersect. +-} +class (Eq a) => Matchable a where + top :: a + intersect :: a -> a -> Maybe a + match :: a -> a -> Bool + overlap :: a -> a -> Bool + disjoint :: a -> a -> Bool + match x y = intersect x y == Just x + overlap x y = isJust $ intersect x y + disjoint x y = isNothing $ intersect x y + +data Wildcard a + = Exact a + | Wildcard + deriving (Ord, Eq) + +data Prefix a = Prefix a Int + deriving (Ord, Eq) + +instance Show a => Show (Wildcard a) where + show Wildcard = "*" + show (Exact a) = show a + +instance Functor Wildcard where + fmap f (Exact a) = Exact (f a) + fmap _ Wildcard = Wildcard + +instance (Bits a, Show a) => Show (Prefix a) where + show (Prefix val significantBits) = + if bitSize val == significantBits + then show val + else "Prefix " ++ show val ++ " " ++ show significantBits + +instance Bits a => Matchable (Prefix a) where + top = Prefix 0 0 + intersect (Prefix v1 sig1) (Prefix v2 sig2) = + let sig = min sig1 sig2 -- shorter prefix + width = bitSize v1 -- value ignored + mask = complement (bit (width - sig) - 1) in -- mask out lower bits + if v1 .&. mask == v2 .&. mask + then + if sig1 > sig2 + then Just (Prefix v1 sig1) + else Just (Prefix v2 sig2) + else Nothing + +instance Eq a => Matchable (Wildcard a) where + top = Wildcard + intersect (Exact a) (Exact b) = if a == b then Just (Exact a) else Nothing + intersect (Exact a) Wildcard = Just (Exact a) + intersect Wildcard (Exact b) = Just (Exact b) + intersect Wildcard Wildcard = Just Wildcard + +wMatch :: Eq a => a -> Wildcard a -> Bool +wMatch b w = Exact b `match` w diff --git a/src/Frenetic/Server.hs b/src/Frenetic/Server.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/Server.hs @@ -0,0 +1,26 @@ +module Frenetic.Server + ( controller + , dynController + ) where + +import Frenetic.Hosts.Nettle +import Frenetic.NetCore.Types +import Frenetic.Common + +-- |Starts an OpenFlow controller that runs dynamic NetCore programs. +-- +-- The controller reads NetCore programs from the given channel. When +-- the controller receives a program on the channel, it compiles it and +-- reconfigures the network to run it. +dynController :: Chan Policy + -> Chan (Loc, ByteString) -- ^packets to emit + -> IO () +dynController = nettleServer + +-- |Starts an OpenFlow controller that runs a static NetCore program. +controller :: Policy -> IO () +controller policy = do + ch <- newChan + writeChan ch policy + pktChan <- newChan + dynController ch pktChan diff --git a/src/Frenetic/Slices/Compile.hs b/src/Frenetic/Slices/Compile.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/Slices/Compile.hs @@ -0,0 +1,265 @@ +module Frenetic.Slices.Compile + ( -- * Compilation + transform + , transformEdge + , dynTransform + , compileSlice + , edgeCompileSlice + -- * Internal tools + , modifyVlan + , setVlan + , matchesSwitch + ) where + +import Control.Monad +import Frenetic.Common +import qualified Data.Map as Map +import qualified Data.MultiSet as MS +import qualified Data.Set as Set +import Frenetic.NetCore.Types +import Frenetic.NetCore.Short +import Frenetic.Pattern +import Frenetic.NetCore.Reduce +import Frenetic.NetCore.Pretty +import Frenetic.Slices.Slice +import Frenetic.Slices.VlanAssignment +import Frenetic.Topo + +-- |Match a specific vlan tag +vlanMatch :: Vlan -> Predicate +vlanMatch vlan = dlVlan vlan + +-- TODO(astory): also take in the packet channel and handle that +-- |Compile a list of slices and dynamic policies as they change. +dynTransform :: [(Slice, Chan Policy)] -> IO (Chan Policy) +dynTransform combined = do + updateChan <- newChan :: IO (Chan (Vlan, Policy)) + outputChan <- newChan :: IO (Chan Policy) + let tagged = zip [1..] combined + -- Fork off threads to poll the input policy channels, compile them, and write + -- them into the unified output channel. + let poll (vlan, (slice, policyChan)) = do + let loop = do + update <- readChan policyChan + let compiled = compileSlice slice vlan update + writeChan updateChan (vlan, compiled) + forkIO $ forever $ loop + mapM_ poll tagged + -- Poll from the unified channel, and update a map containing the most recent + -- compiled version of each slice. After each update, take the union and send + -- the result down the pipe. + let loop map = do + (vlan, compiled) <- readChan updateChan + let map' = Map.insert vlan compiled map + writeChan outputChan $ mconcat (Map.elems map') + loop map' + forkIO $ loop Map.empty + return outputChan + +-- |Produce the combined policy by compiling a list of slices and policies with +-- the vanilla compiler +transform :: [(Slice, Policy)] -> Policy +transform combined = mconcat policies + where + tagged = sequential combined + policies = map (\(vlan, (slice, policy)) -> compileSlice slice vlan policy) + tagged + +-- |Produce the combined policy by compiling a list of slices and policies with +-- the edge compiler +transformEdge :: Topo -> [(Slice, Policy)] -> Policy +transformEdge topo combined = mconcat policies where + tagged = edge topo combined + policies = map (\(assignment, (slice, policy)) -> + edgeCompileSlice slice assignment policy) + tagged + +-- TODO(astory): egress predicates +-- |Compile a slice with a vlan key +compileSlice :: Slice -> Vlan -> Policy -> Policy +compileSlice slice vlan policy = + if poUsesVlans policy then error "input policy uses VLANs." else + let localPolicy = localize slice policy in + -- A postcondition of localize is that all the forwarding actions of the + -- policy make sense wrt the slice, and that every PoBasic matches at most one + -- switch. This is a precondition for outport + let safePolicy = isolate slice vlan localPolicy in + let inportPolicy = inportPo slice vlan localPolicy in + let safeInportPolicy = PoUnion safePolicy inportPolicy in + reduce $ outport slice safeInportPolicy + +-- | Compile a slice with an assignment of VLAN tags to ports. For this to work +-- properly, the assignment of tags to both ends of an edge must be the same +edgeCompileSlice :: Slice -> Map.Map Loc Vlan -> Policy -> Policy +edgeCompileSlice slice assignment policy = mconcat (queryPols : forwardPols) + where + localPolicy = localize slice policy + -- separate out queries to avoid multiplying them during the fracturing that + -- goes on in creating the internal and external policies. + queryPols = queryOnly slice assignment localPolicy + forwardPols = forwardEdges slice assignment localPolicy + +-- |Produce a list of policies that together implement just the query portion of +-- the policy running on the slice +queryOnly :: Slice -> Map.Map Loc Vlan -> Policy -> Policy +queryOnly slice assignment policy = justQueries <%> (onSlice <||> inBound) where + onSlice = prOr . map onPort . Set.toList $ internal slice + inBound = ingressPredicate slice <&&> dlNoVlan + justQueries = removeForwards policy + onPort l@(Loc s p) = inport s p <&&> dlVlan vlan <&&> + Map.findWithDefault top l (ingress slice) where + vlan = case Map.lookup l assignment of + Just v -> v + Nothing -> error $ + "assignment map incomplete at " ++ show l ++ + "\nmap: " ++ show assignment ++ + "\nslice: " ++ show (internal slice) + +-- |Remove forwarding actions from policy leaving only queries +removeForwards :: Policy -> Policy +removeForwards PoBottom = PoBottom +removeForwards (PoBasic pred (Action _ qs)) = PoBasic pred (Action MS.empty qs) +removeForwards (PoUnion p1 p2) = PoUnion p1' p2' where + p1' = removeForwards p1 + p2' = removeForwards p2 + +-- |Remove queries from policy leaving only forwarding actions +removeQueries :: Policy -> Policy +removeQueries PoBottom = PoBottom +removeQueries (PoBasic pred (Action fs _)) = PoBasic pred (Action fs MS.empty) +removeQueries (PoUnion p1 p2) = PoUnion p1' p2' where + p1' = removeQueries p1 + p2' = removeQueries p2 + +-- |Remove forwarding actions to ports other than p +justTo :: Port -> Policy -> Policy +justTo _ PoBottom = PoBottom +justTo p (PoBasic pred (Action fs qs)) = PoBasic pred (Action fs' qs) where + fs' = MS.filter matches fs + matches (Physical p', _) = p == p' + matches (AllPorts, _) = error "AllPorts found while compiling." +justTo p (PoUnion p1 p2) = PoUnion p1' p2' where + p1' = justTo p p1 + p2' = justTo p p2 + +-- TODO(astory): egress predicates +-- |Produce a list of policies that together instrument the edge-compiled +-- internal policy. This only considers internal -> internal and internal -> +-- external forwarding. +forwardEdges :: Slice -> Map.Map Loc Vlan -> Policy -> [Policy] +forwardEdges slice assignment policy = concatMap buildPort locs where + int = internal slice + ing = Map.keysSet (ingress slice) + egr = Map.keysSet (egress slice) + portLookup = portsOfSet (Set.union int (Set.union ing egr)) + locs = Set.toList (Set.union int ing) + buildPort :: Loc -> [Policy] -- Get the policies for packets to one location + buildPort l@(Loc s p) = map hop $ Set.toList destinations where + destinations = case Map.lookup s portLookup of + Just dests -> dests + Nothing -> error "Port lookup malformed." + ourVlan = if Set.member l ing then dlNoVlan + else case Map.lookup l assignment of + Just v -> dlVlan v + Nothing -> error "Vlan assignment malformed." + restriction = inport s p <&&> + ourVlan <&&> + Map.findWithDefault top l (ingress slice) + policy' = policy <%> restriction + hop :: Port -> Policy -- Get the policies for one switch forwarding + hop port = policy''' where + loc = Loc s port + targetVlan = if Set.member loc egr then Nothing + else case Map.lookup loc assignment of + Just v -> Just v + Nothing -> error "Vlan assignment malformed." + policy'' = justTo port policy' + -- It's safe to use modifyVlan because we only have actions on this one + -- forwarding hop. + policy''' = modifyVlan targetVlan policy'' + +portsOfSet :: Set.Set Loc -> Map.Map Switch (Set.Set Port) +portsOfSet = Map.fromListWith Set.union . + map (\(Loc s p) -> (s, Set.singleton p)) . + Set.toList + +-- |Produce a policy that only considers traffic on this vlan and on internal +-- ports. Note that if the policy does not modify vlans, then it also only +-- emits traffic on this vlan. +isolate :: Slice -> Vlan -> Policy -> Policy +isolate slice vlan policy = policy <%> (vlPred <&&> intern) + where + vlPred = vlanMatch vlan + intern = prOr . map (\(Loc s p) -> inport s p) . Set.toList $ + internal slice + +locToPred :: Loc -> Predicate +locToPred (Loc switch port) = inport switch port + +-- |Produce a policy that moves packets into the vlan as defined by the slice's +-- input policy. +inportPo :: Slice -> Vlan -> Policy -> Policy +inportPo slice vlan policy = + let incoming = ingressPredicate slice in + let policyIntoVlan = modifyVlan (Just vlan) policy in + policyIntoVlan <%> (incoming <&&> dlNoVlan) + +-- |Produce a new policy the same as the old, but wherever a packet leaves an +-- outgoing edge, unset its VLAN. Precondition: every PoBasic must match at +-- most one switch. +outport :: Slice -> Policy -> Policy +outport slice policy = foldr stripVlan policy locs + where locs = Map.keys (egress slice) + +-- |Produce a predicate matching any of the inports (and their predicate) +-- specified +ingressPredicate :: Slice -> Predicate +ingressPredicate slice = + prOr . map ingressSpecToPred . Map.assocs $ ingress slice + +-- |Produce a predicate matching the ingress predicate at a particular location +ingressSpecToPred :: (Loc, Predicate) -> Predicate +ingressSpecToPred (loc, pred) = PrIntersect pred (locToPred loc) + +-- |Walk through the policy and globally set VLAN to vlan at each forwarding +-- action +modifyVlan :: Maybe Vlan -> Policy -> Policy +modifyVlan _ PoBottom = PoBottom +modifyVlan vlan (PoBasic pred (Action m obs)) = PoBasic pred (Action m' obs) + where + m' = MS.map setVlans m + setVlans (p, mod) = (p, mod {modifyDlVlan = Just vlan}) +modifyVlan vlan (PoUnion p1 p2) = PoUnion (modifyVlan vlan p1) + (modifyVlan vlan p2) + +-- |Unset vlan for packets forwarded to location (without link transfer) and +-- leave rest of policy unchanged. Note that this assumes that each PoBasic +-- matches at most one switch. +stripVlan :: Loc -> Policy -> Policy +stripVlan = setVlan Nothing + +-- |Set vlan tag for packets forwarded to location (without link transfer) and +-- leave rest of policy unchanged. Note that this assumes that each PoBasic +-- matches at most one switch. +setVlan :: Maybe Vlan -> Loc -> Policy -> Policy +setVlan _ _ PoBottom = PoBottom +setVlan vlan loc (PoUnion p1 p2) = PoUnion (setVlan vlan loc p1) + (setVlan vlan loc p2) +setVlan vlan (Loc switch port) pol@(PoBasic pred (Action m obs)) = + if matchesSwitch switch pred then PoBasic pred (Action m' obs) + else pol + where + m' = MS.map setVlanOnPort m + setVlanOnPort (Physical p, mod) = + if p == port then (Physical p, mod {modifyDlVlan = Just vlan}) + else (Physical p, mod) + setVlanOnPort (AllPorts, mod) = + error "AllPorts encountered in slice compilation. Did you first localize?" + +-- |Determine if a predicate can match any packets on a switch (overapproximate) +matchesSwitch :: Switch -> Predicate -> Bool +matchesSwitch _ (PrPattern _) = True +matchesSwitch s1 (PrTo s2) = s1 == s2 +matchesSwitch s (PrUnion p1 p2) = matchesSwitch s p1 || matchesSwitch s p2 +matchesSwitch s (PrIntersect p1 p2) = matchesSwitch s p1 && matchesSwitch s p2 +matchesSwitch s (PrNegate _) = True diff --git a/src/Frenetic/Slices/Slice.hs b/src/Frenetic/Slices/Slice.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/Slices/Slice.hs @@ -0,0 +1,147 @@ +module Frenetic.Slices.Slice + ( -- * Data Structures + Slice (..) + -- * Utilities + , internalSlice + , simpleSlice + , localize + , switchesOfPredicate + , poUsesVlans + , actUsesVlans + ) where + +import Frenetic.Common +import Data.Graph.Inductive.Graph +import Data.List +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.MultiSet as MS +import qualified Data.Set as Set +import Data.Word +import Frenetic.NetCore.Short +import Frenetic.NetCore.Types +import Frenetic.Pattern +import Frenetic.Topo + +-- |A slice represents a subgraph of the network for the purposes of isolating +-- programs from each other. +-- +-- The interface to a slice has two components: a topology comprising switches, +-- ports, and links; and a collection of predicates, one for each outward-facing +-- edge port. +-- +-- We represent the topology as a collection of locations in the network, and +-- the predicates as a mapping from locations to predicates. +-- +-- Intuitively, packets may travel freely between internal locations, but must +-- satisfy the associated predicate to enter the slice at an ingress location, +-- or leave the slice at an egress location. If an external port is not listed +-- in the ingress or egress set, then no packets may enter or leave +-- (respectively) on that port. +data Slice = Slice { + -- |Ports internal to the slice. + internal :: Set.Set Loc + -- |External ports, and restrictions on inbound packets. +, ingress :: Map.Map Loc Predicate + -- |External ports, and restrictions on outbound packets. +, egress :: Map.Map Loc Predicate } deriving (Eq, Ord, Show) + +linkToLoc (n, _, p) = Loc (fromIntegral n) p + +-- |Produce a slice that exactly covers the given topology, with no ingress or +-- egress ports. +internalSlice :: Topo -> Slice +internalSlice topo = Slice locations Map.empty Map.empty where + locations = Set.fromList . map linkToLoc . labEdges $ topo + +-- |Produce a slice with all the switches in topo, and predicate applied to all +-- in- and out-bound connections to hosts +simpleSlice :: Topo -> Predicate -> Slice +simpleSlice topo pred = Slice int (Map.fromList $ zip ext (repeat pred)) + (Map.fromList $ zip ext (repeat pred)) + where + links = labEdges topo + -- Only get links coming from switches, and segregate based on pointing to a + -- host or not. + (intLinks, extLinks) = partition (\(_, n2, _) -> not $ isHost topo n2) . + filter (\(_, _, p) -> p /= 0) $ + links + int = Set.fromList $ map linkToLoc intLinks + ext = map linkToLoc extLinks + +-- |Transform policy running on slice into a FLOOD- and unbound port-free (i.e., +-- every port has an unambiguous switch associated with it) version with the +-- same semantics, assuming it runs on the subgraph described by the slice. In +-- the returned policy, all forwarding actions within the slice, or to one of +-- its egress ports. +localize :: Slice -> Policy -> Policy +localize slice policy = case policy of + PoBottom -> PoBottom + PoUnion p1 p2 -> localize slice p1 <+> localize slice p2 + PoBasic pred act -> + let ss = Set.toList (switchesOfPredicate switches pred) in + mconcat [localizeMods (pred' <&&> PrTo s) act + (Map.findWithDefault Set.empty s ports) + | s <- ss] + where + switches = Set.map (\ (Loc s _) -> s) locations + ports = + Set.foldr (\ (Loc s p) -> Map.insertWith Set.union s (Set.singleton p)) + Map.empty locations + locations = Set.union (internal slice) + (Set.fromList . Map.keys $ egress slice) + pred' = pred <&&> onSlice slice + +onSlice :: Slice -> Predicate +onSlice (Slice int ing egr) = prOr . + map (\(Loc s p) -> inport s p) . + Set.toList . + Set.unions $ + [int, Map.keysSet ing, Map.keysSet egr] + +-- |Transform potentially non-local forwarding actions into explicitly local +-- ones on the switch. +localizeMods :: Predicate -> Action -> Set.Set Port -> Policy +localizeMods pred (Action m obs) ports = mconcat (forwardPol : floodPols) + where + (forwards, floods) = MS.mapEither split m + -- partial match is safe because we split it + forwards' = MS.filter (\(Physical p, _) -> Set.member p ports) forwards + -- Put the observations with the forwards so we don't duplicate them + forwardPol = pred ==> Action forwards' obs + floodPols = [mkFlood p mods | p <- Set.toList ports, mods <- MS.toList floods] + mkFlood port mods = pred <&&> inPort port ==> Action mods' MS.empty where + mods' = MS.fromList [(Physical p, mods) | p <- otherPorts] + otherPorts = Set.toList $ Set.delete port ports + +split (Physical p, rewrite) = Left (Physical p, rewrite) +split (AllPorts, rewrite) = Right rewrite + +-- |Starting with a set of switches, get the switches the predicate might match. +switchesOfPredicate :: Set.Set Switch -> Predicate -> Set.Set Switch +switchesOfPredicate switches pred = case pred of + PrPattern _ -> switches + PrTo s -> Set.intersection switches (Set.singleton s) + PrUnion p1 p2 -> Set.union (switchesOfPredicate switches p1) + (switchesOfPredicate switches p2) + PrIntersect p1 p2 -> Set.intersection (switchesOfPredicate switches p1) + (switchesOfPredicate switches p2) + PrNegate _ -> switches + +-- |Determine if a policy ever matches on or sets VLAN tags. +poUsesVlans :: Policy -> Bool +poUsesVlans PoBottom = False +poUsesVlans (PoUnion p1 p2) = poUsesVlans p1 || poUsesVlans p2 +poUsesVlans (PoBasic pred action) = prUsesVlans pred || actUsesVlans action + +-- |Determine if a predicate matches on VLAN tags +prUsesVlans :: Predicate -> Bool +prUsesVlans (PrPattern (Pattern {ptrnDlVlan = vl})) = vl /= Wildcard +prUsesVlans (PrTo _) = False +prUsesVlans (PrUnion p1 p2) = prUsesVlans p1 || prUsesVlans p2 +prUsesVlans (PrIntersect p1 p2) = prUsesVlans p1 || prUsesVlans p2 +prUsesVlans (PrNegate p) = prUsesVlans p + +actUsesVlans :: Action -> Bool +actUsesVlans (Action ms _) = + any (\(_, m) -> isJust $ modifyDlVlan m) $ MS.toList ms diff --git a/src/Frenetic/Slices/VlanAssignment.hs b/src/Frenetic/Slices/VlanAssignment.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/Slices/VlanAssignment.hs @@ -0,0 +1,68 @@ +module Frenetic.Slices.VlanAssignment + ( sequential + , edge + ) where + +import Data.Maybe +import Data.Word +import qualified Data.Map as Map +import qualified Data.Set as Set +import Frenetic.NetCore.Short +import Frenetic.NetCore.Types +import Frenetic.Slices.Slice +import Frenetic.Topo + +maxVlan :: Vlan +maxVlan = 2^12 + +sequential :: [(Slice, Policy)] -> [(Vlan, (Slice, Policy))] +sequential combined = + if length combined > fromIntegral maxVlan + then error (show (length combined) ++ + " is too many VLANs to compile sequentially.") + else zip [1..maxVlan] combined + +type Edge = (Loc, Loc) + +edge :: Topo -> [(Slice, Policy)] -> [(Map.Map Loc Vlan, (Slice, Policy))] +edge topo combined = paired where + locUse :: Map.Map Loc (Set.Set (Slice, Policy)) + locUse = foldr addEdges Map.empty combined + + edgeUse :: Map.Map Edge (Set.Set (Slice, Policy)) + -- getEdge returns the normal form (smallest first) + edgeUse = Map.mapKeysWith Set.union (getEdge topo) locUse + + vlanEdges :: Map.Map Edge (Map.Map (Slice, Policy) Vlan) + vlanEdges = Map.map assign edgeUse + + vlans :: Map.Map Loc (Map.Map (Slice, Policy) Vlan) + vlans = Map.fromList . + concatMap (\ ((l1, l2), v) -> [(l1, v), (l2, v)]) . + Map.toList $ + vlanEdges + + bySlice :: Map.Map (Slice, Policy) (Map.Map Loc Vlan) + bySlice = invert vlans + + paired = [ (lookup, both) | (both, lookup) <- Map.toList bySlice] + +-- | Add (loc, slice) to map for all internal locations in slice +addEdges :: (Slice, Policy) -> Map.Map Loc (Set.Set (Slice, Policy)) -> + Map.Map Loc (Set.Set (Slice, Policy)) +addEdges (slice, policy) m = Map.unionWith Set.union (Map.fromList locations) m where + locations = map (\l -> (l, Set.singleton (slice, policy))) . + Set.toList $ internal slice + +assign :: Set.Set (Slice, Policy) -> Map.Map (Slice, Policy) Vlan +assign slices = + if Set.size slices > fromIntegral maxVlan + then error (show (Set.size slices) ++ + " is too many VLANs to compile sequentially.") + else Map.fromList $ zip (Set.toList slices) [1..maxVlan] + +invert :: (Ord a, Ord b) => Map.Map a (Map.Map b v) -> Map.Map b (Map.Map a v) +invert m = m' where + associations = map (\(k, submap) -> (k, Map.toList submap)) . Map.toList $ m + m' = Map.fromListWith Map.union + [(b, Map.singleton a v) | (a, bs) <- associations, (b, v) <- bs] diff --git a/src/Frenetic/Switches/OpenFlow.hs b/src/Frenetic/Switches/OpenFlow.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/Switches/OpenFlow.hs @@ -0,0 +1,304 @@ +module Frenetic.Switches.OpenFlow + ( prefixToIPAddressPrefix + , ipAddressPrefixToPrefix + , OpenFlow (..) + , toOFPkt + , fromOFPkt + , toOFPat + , fromOFPat + , toOFAct + , fromOFAct + , Nettle (..) + , actQueries + ) where + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (catMaybes) + +import Data.HList +import Control.Concurrent.Chan +import Data.Bits +import qualified Data.Set as Set +import qualified Data.MultiSet as MS +import Data.Word +import Data.List (nub, find) +import qualified Nettle.IPv4.IPAddress as IPAddr +import Nettle.Ethernet.AddressResolutionProtocol +import Frenetic.Pattern +import Frenetic.Compat +import Frenetic.NetCore.Types +import Control.Concurrent +import Frenetic.NettleEx hiding (AllPorts, ethernetAddress64) +import qualified Frenetic.NettleEx as NettleEx + +{-| Convert an EthernetAddress to a Word48. -} +ethToWord48 :: NettleEx.EthernetAddress + -> Frenetic.NetCore.Types.EthernetAddress +ethToWord48 = ethernetAddress64.unpack64 + +{-| Convert a Word48 to an EthernetAddress. -} +word48ToEth :: Frenetic.NetCore.Types.EthernetAddress + -> NettleEx.EthernetAddress +word48ToEth = NettleEx.ethernetAddress64 . unpackEth64 + + +{-| Convert a pattern Prefix to an IPAddressPrefix. -} +prefixToIPAddressPrefix :: Prefix Word32 -> IPAddressPrefix +prefixToIPAddressPrefix (Prefix x len) = (IPAddress x, fromIntegral len) + +{-| Convert an IPAddressPrefix to a pattern Prefix. -} +ipAddressPrefixToPrefix :: IPAddressPrefix -> Prefix Word32 +ipAddressPrefixToPrefix (IPAddress x, len) = Prefix x (fromIntegral len) + +instance Matchable IPAddressPrefix where + top = defaultIPPrefix + intersect = IPAddr.intersect + +physicalPortOfPseudoPort (Physical p) = PhysicalPort p +physicalPortOfPseudoPort AllPorts = Flood + +toController :: ActionSequence +toController = sendToController maxBound + +instance Eq a => Matchable (Maybe a) where + top = Nothing + intersect (Just a) (Just b) = if a == b then Just (Just a) else Nothing + intersect (Just a) Nothing = Just (Just a) + intersect Nothing (Just b) = Just (Just b) + intersect Nothing Nothing = Just Nothing + +wildcardToMaybe (Exact a) = Just a +wildcardToMaybe Wildcard = Nothing + +maybeToWildcard (Just a) = Exact a +maybeToWildcard Nothing = Wildcard + +instance Matchable Match where + top = Match { + inPort = Nothing, + srcEthAddress = top, + dstEthAddress = top, + vLANID = top, + vLANPriority = top, + ethFrameType = top, + ipTypeOfService = top, + matchIPProtocol = top, + srcIPAddress = top, + dstIPAddress = top, + srcTransportPort = top, + dstTransportPort = top } + + intersect ofm1 ofm2 = + do inport <- intersect (inPort ofm1) (inPort ofm2) + srcethaddress <- intersect (srcEthAddress ofm1) (srcEthAddress ofm2) + dstethaddress <- intersect (dstEthAddress ofm1) (dstEthAddress ofm2) + vlanid <- intersect (vLANID ofm1) (vLANID ofm2) + vlanpriority <- intersect (vLANPriority ofm1) (vLANPriority ofm2) + ethframetype <- intersect (ethFrameType ofm1) (ethFrameType ofm2) + iptypeofservice <- intersect (ipTypeOfService ofm1) (ipTypeOfService ofm2) + ipprotocol <- intersect (matchIPProtocol ofm1) (matchIPProtocol ofm2) + srcipaddress <- intersect (srcIPAddress ofm1) (srcIPAddress ofm2) + dstipaddress <- intersect (dstIPAddress ofm1) (dstIPAddress ofm2) + srctransportport <- intersect (srcTransportPort ofm1) (srcTransportPort ofm2) + dsttransportport <- intersect (dstTransportPort ofm1) (dstTransportPort ofm2) + return Match { + inPort = inport, + srcEthAddress = srcethaddress, + dstEthAddress = dstethaddress, + vLANID = vlanid, + vLANPriority = vlanpriority, + ethFrameType = ethframetype, + ipTypeOfService = iptypeofservice, + matchIPProtocol = ipprotocol, + srcIPAddress = srcipaddress, + dstIPAddress = dstipaddress, + srcTransportPort = srctransportport, + dstTransportPort = dsttransportport } + + +nettleEthernetFrame pkt = case enclosedFrame pkt of + Left err -> Nothing + Right ef -> Just ef + +nettleEthernetHeaders pkt = case enclosedFrame pkt of + Right (HCons hdr _) -> Just hdr + Left _ -> Nothing + +nettleEthernetBody pkt = case enclosedFrame pkt of + Right (HCons _ (HCons body _)) -> Just body + Left _ -> Nothing + + + +data OpenFlow = OpenFlow Nettle + +instance Matchable (PatternImpl OpenFlow) where + top = OFPat top + intersect (OFPat p1) (OFPat p2) = case Frenetic.Pattern.intersect p1 p2 of + Just p3 -> Just (OFPat p3) + Nothing -> Nothing + +toOFPkt :: PacketInfo -> PacketImpl OpenFlow +toOFPkt p = OFPkt p + +fromOFPkt :: PacketImpl OpenFlow -> PacketInfo +fromOFPkt (OFPkt p) = p + +toOFPat :: Match -> PatternImpl OpenFlow +toOFPat p = OFPat p + +fromOFPat :: PatternImpl OpenFlow -> Match +fromOFPat (OFPat p) = p + +toOFAct :: ActionSequence -> ActionImpl OpenFlow +toOFAct p = OFAct p [] + +instance Show (ActionImpl OpenFlow) where + show (OFAct acts ls) = show acts ++ " and " ++ show (length ls) ++ " queries" + +ifNothing :: Maybe a -> a -> a +ifNothing (Just a) _ = a +ifNothing Nothing b = b + +modTranslate :: Modification -> ActionSequence +modTranslate (Modification{..}) = + catMaybes [f1, f2, f3, f4, f5, f6, f7, f8, f9] + where f1 = case modifyDlSrc of + Nothing -> Nothing + Just v -> Just $ SetEthSrcAddr $ word48ToEth v + f2 = case modifyDlDst of + Nothing -> Nothing + Just v -> Just $ SetEthDstAddr $ word48ToEth v + f3 = case modifyDlVlan of + Nothing -> Nothing + Just (Just v) -> Just $ SetVlanVID v + Just Nothing -> Just StripVlanHeader + f4 = case modifyDlVlanPcp of + Nothing -> Nothing + Just v -> Just $ SetVlanPriority v + f5 = case modifyNwSrc of + Nothing -> Nothing + Just ip -> Just $ SetIPSrcAddr $ IPAddress ip + f6 = case modifyNwDst of + Nothing -> Nothing + Just ip -> Just $ SetIPDstAddr $ IPAddress ip + f7 = case modifyNwTos of + Nothing -> Nothing + Just v -> Just $ SetIPToS v + f8 = case modifyTpSrc of + Nothing -> Nothing + Just v -> Just $ SetTransportSrcPort v + f9 = case modifyTpDst of + Nothing -> Nothing + Just v -> Just $ SetTransportDstPort v + +instance FreneticImpl OpenFlow where + data PacketImpl OpenFlow = OFPkt PacketInfo deriving (Show, Eq) + data PatternImpl OpenFlow = OFPat Match deriving (Show, Eq) + data ActionImpl OpenFlow = OFAct { fromOFAct :: ActionSequence, + actQueries :: [Query] } + deriving (Eq) + + ptrnMatchPkt (OFPkt pkt) (OFPat ptrn) = case nettleEthernetFrame pkt of + Just frame -> matches (receivedOnPort pkt, frame) ptrn + Nothing -> False + + toPacket (OFPkt pkt) = do + hdrs <- nettleEthernetHeaders pkt + body <- nettleEthernetBody pkt + proto <- ethProto body + tos <- ethTOS body + return $ Packet (ethToWord48 (sourceMACAddress hdrs)) + (ethToWord48 (destMACAddress hdrs)) + (typeCode hdrs) + (ethVLANId hdrs) + (ethVLANPcp hdrs) + (ethSrcIP body) + (ethDstIP body) + proto + tos + (srcPort body) + (dstPort body) + (receivedOnPort pkt) + + fromPattern ptrn = OFPat Match { + srcEthAddress = wildcardToMaybe $ fmap word48ToEth (ptrnDlSrc ptrn), + dstEthAddress = wildcardToMaybe $ fmap word48ToEth (ptrnDlDst ptrn), + ethFrameType = wildcardToMaybe $ ptrnDlTyp ptrn, + vLANID = case ptrnDlVlan ptrn of + Exact (Just vl) -> Just vl + Exact Nothing -> Just $ fromInteger ofpVlanNone + Wildcard -> Nothing, + vLANPriority = wildcardToMaybe $ ptrnDlVlanPcp ptrn, + srcIPAddress = prefixToIPAddressPrefix (ptrnNwSrc ptrn), + dstIPAddress = prefixToIPAddressPrefix (ptrnNwDst ptrn), + matchIPProtocol = wildcardToMaybe $ ptrnNwProto ptrn, + ipTypeOfService = wildcardToMaybe $ ptrnNwTos ptrn, + srcTransportPort = wildcardToMaybe $ ptrnTpSrc ptrn, + dstTransportPort = wildcardToMaybe $ ptrnTpDst ptrn, + inPort = wildcardToMaybe $ ptrnInPort ptrn + } + + toPattern (OFPat ptrn) = Pattern { + ptrnDlSrc = maybeToWildcard $ fmap ethToWord48 $ srcEthAddress ptrn, + ptrnDlDst = maybeToWildcard $ fmap ethToWord48 $ dstEthAddress ptrn, + ptrnDlTyp = maybeToWildcard $ ethFrameType ptrn, + ptrnDlVlan = case vLANID ptrn of + Just vl | vl == fromIntegral ofpVlanNone -> Exact Nothing + | otherwise -> Exact (Just vl) + Nothing -> Wildcard, + ptrnDlVlanPcp = maybeToWildcard $ vLANPriority ptrn, + ptrnNwSrc = ipAddressPrefixToPrefix $ srcIPAddress ptrn, + ptrnNwDst = ipAddressPrefixToPrefix $ dstIPAddress ptrn, + ptrnNwProto = maybeToWildcard $ matchIPProtocol ptrn, + ptrnNwTos = maybeToWildcard $ ipTypeOfService ptrn, + ptrnTpSrc = maybeToWildcard $ srcTransportPort ptrn, + ptrnTpDst = maybeToWildcard $ dstTransportPort ptrn, + ptrnInPort = maybeToWildcard $ inPort ptrn + } + + actnController = OFAct toController [] + actnDefault = OFAct toController [] + + -- Not all multisets of actions can be translated to lists of OpenFlow + -- actions. For example, consider the set + -- + -- {(SrcIP = 0, Fwd 1), (DstIP = 1, Fwd 2)}. + -- + -- In general, it is not possible to set SrcIP to 0, forward out port 1, + -- and then revert the SrcIP to its original value before setting DstIP to 1 + -- and forwarding out port 2. In such situations, the action is changed to + -- "send to controller." + -- TODO: implement optimizations to handle special cases on the switch. + -- TODO: deploying these kinds of actions relies on the controller to forward + -- them. will this corrupt/drop packets larger than maxBound? + + -- The ToController action needs to come last. If you reorder, it will not + -- work. Observed with the usermode switch. + actnTranslate act@(Action fwd queries) = OFAct (ofFwd ++ toCtrl) (MS.toList queries) + where acts = if hasUnimplementableMods $ map snd $ MS.toList fwd + then [SendOutPort (ToController maxBound)] + else ofFwd ++ toCtrl + ofFwd = concatMap (\(pp, md) -> modTranslate md + ++ [SendOutPort (physicalPortOfPseudoPort pp)]) + $ MS.toList fwd + toCtrl = case find isPktQuery (MS.toList queries) of + -- sends as much of the packet as possible to the controller + Just _ -> [SendOutPort (ToController maxBound)] + Nothing -> [] + hasUnimplementableMods as + | length as <= 1 = False + | otherwise = + let minFields = foldl (\m p -> if Set.size p < Set.size m then p else m) + (modifiedFields $ head as) + (map modifiedFields $ tail as) + in not $ all (\pat -> Set.isSubsetOf (modifiedFields pat) minFields) as + + actnControllerPart (OFAct _ queries) switchID ofPkt = do + let pktChans = map pktQueryChan . filter isPktQuery $ queries + let sendParsablePkt chan = case toPacket ofPkt of + Nothing -> return () + Just pk -> writeChan chan (switchID, pk) + mapM_ sendParsablePkt pktChans + diff --git a/src/Frenetic/Topo.hs b/src/Frenetic/Topo.hs new file mode 100644 --- /dev/null +++ b/src/Frenetic/Topo.hs @@ -0,0 +1,103 @@ +module Frenetic.Topo + ( Topo + , buildGraph + , getEdgeLabel + , getEdge + , reverseLoc + , subgraph + , isHost + , switches + , hosts + , lPorts + , ports + ) where + +import Data.Graph.Inductive.Graph +import Data.Graph.Inductive.Tree +import qualified Data.List as List +import qualified Data.Set as Set + +import Frenetic.NetCore.Types + +type Topo = Gr () Port + +-- | Build a graph from list of undirected edges labeled with their ports +-- Ensures that the resulting graph is undirected-equivalent, and labels each +-- "directed" edge with the appropriate port to send a packet over that edge +-- from the source switch. +-- +-- By convention, hosts have a single port 0, and non-hosts have any number of +-- non-zero ports. If 0 is in the ports of a node, it is considered to be a +-- host regardless of other ports that may be present. +buildGraph :: [((Node, Port), (Node, Port))] -> Topo +buildGraph links = mkGraph nodes edges where + nodes = Set.toList . + Set.unions $ + map (\ ((n1, _), (n2, _)) -> Set.fromList [(n1, ()), (n2, ())]) + links + edges = Set.toList . + Set.unions $ + map (\ ((n1, p1), (n2, p2)) -> + Set.fromList [(n1, n2, p1), (n2, n1, p2)]) + links + +-- | Get the subgraph that only contains the nodes matched by the predicate +filterGr :: (Graph gr) => (LNode a -> Bool) -> gr a b -> gr a b +filterGr pred gr = delNodes badNodes gr where + badNodes = map fst . filter (not . pred) . labNodes $ gr + +-- | Get the subgraph only containing nodes +subgraph :: (Graph gr) => Set.Set Node -> gr a b -> gr a b +subgraph nodes gr = filterGr (\(n, _) -> Set.member n nodes) gr + +-- | Maybe get the label of the edge from n1 to n2 +getEdgeLabel :: (Graph gr) => gr a b -> Node -> Node -> Maybe b +getEdgeLabel gr n1 n2 = lookup n2 (lsuc gr n1) + +-- | Put an edge into a normal form (lowest location first) +normal :: (Loc, Loc) -> (Loc, Loc) +normal (l1, l2) = if l1 < l2 then (l1, l2) else (l2, l1) + +-- | Get the normalized pair of locations that one location is on +getEdge :: Topo -> Loc -> (Loc, Loc) +getEdge topo loc = normal (loc, reverseLoc topo loc) + +-- | Maybe get the reverse of a location +reverseLoc :: Topo -> Loc -> Loc +reverseLoc topo loc@(Loc switch port) = + Loc (fromIntegral targetSwitch) targetPort + where + mTargetSwitch = List.find (\(_, port') -> port == port') $ + lsuc topo (fromIntegral switch) + (targetSwitch, _) = case mTargetSwitch of + Just s -> s + Nothing -> + error ("Location invalid: could not find dest for " + ++ show loc ++ " among " + ++ show (labEdges topo)) + mTargetPort = getEdgeLabel topo targetSwitch (fromIntegral switch) + targetPort = case mTargetPort of + Just p -> p + Nothing -> error ("Graph not undirected, inverse missing of: " + ++ show loc) + +-- | Get the switches of a topology. A switch is a node with no port 0 +switches :: (Graph gr) => gr a Port -> [Node] +switches topo = filter (not . isHost topo) $ nodes topo + +hostPort :: Port +hostPort = 0 +isHost :: (Graph gr) => gr a Port -> Node -> Bool +isHost topo node = elem hostPort (ports topo node) + +-- | Get the hosts of a topology. A host is a node with only one port, 0. +hosts :: (Graph gr) => gr a Port -> [Node] +hosts topo = filter (isHost topo) $ nodes topo + +-- |Get the (dest, port) of a switch in the topology +lPorts :: (Graph gr) => gr a Port -> Node -> [(Node, Port)] +lPorts topo n = lsuc topo n + +-- |Get the ports of a switch in the topology. +ports :: (Graph gr) => gr a Port -> Node -> [Port] +ports topo = map snd . lPorts topo diff --git a/testsuite/Main.hs b/testsuite/Main.hs new file mode 100644 --- /dev/null +++ b/testsuite/Main.hs @@ -0,0 +1,42 @@ +module Main where + +import Data.List +import System.Environment + +import Tests.Frenetic.NetCore.TestCompiler +import Tests.Frenetic.NetCore.TestNetCore +import Tests.Frenetic.Slices.TestCompile +import Tests.Frenetic.Slices.TestEndToEnd +import Tests.Frenetic.Slices.TestSlice +import Tests.Frenetic.Slices.TestVerification +import Tests.Frenetic.Slices.TestVlanAssignment +import Tests.Frenetic.Switches.TestSwitches +import Tests.Frenetic.TestCompat +import Tests.Frenetic.TestSat +import Test.HUnit +import Test.Framework + +main = do + args <- getArgs + let sat = elem "sat" args + let ourTests = if sat then satTestGroup : mainTests else mainTests + let args' = if sat then delete "sat" args else args + defaultMainWithArgs ourTests args' + +mainTests = + [ + compilerTests + , netCoreTests + , switchTests + , compatTests + , testGroup "Slice tests" [ sliceCompileTests + , sliceTests + , sliceVerificationTests + , vlanAssignmentTests + ] + ] + +satTestGroup = testGroup "SAT tests" [ + satTests + , endToEndTests + ]