packages feed

netcore (empty) → 1.0.0

raw patch · 44 files changed

+7520/−0 lines, 44 filesdep +HListdep +HUnitdep +QuickChecksetup-changed

Dependencies added: HList, HUnit, QuickCheck, ansi-wl-pprint, base, bimap, binary, binary-strict, bytestring, containers, fgl, hslogger, mtl, multiset, network, parsec, process, random, syb, test-framework, test-framework-hunit, test-framework-quickcheck2, test-framework-th

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ netcore.cabal view
@@ -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 <arjun@cs.cornell.edu>,+                  Cole Schlesinger <cschlesi@cs.princeton.edu>,+                  Alec Story <avs38@cornell.edu>+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+  <https://github.com/frenetic-lang/netcore/tree/master/examples>++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
+ nettle-openflow/src/Nettle/Ethernet/AddressResolutionProtocol.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE MultiParamTypeClasses, RecordWildCards, TypeOperators #-}++module Nettle.Ethernet.AddressResolutionProtocol ( +  ARPPacket (..)+  , ARPQueryPacket(..)+  , ARPReplyPacket(..)+  , getARPPacket+  , getARPPacket2+  , putARPPacket+  ) where++import Nettle.Ethernet.EthernetAddress+import Nettle.IPv4.IPAddress+import Data.Binary+import Data.Binary.Put+import Data.Word+import Control.Monad+import Control.Monad.Error+import Data.HList+import qualified Data.Binary.Strict.Get as Strict+import qualified Nettle.OpenFlow.StrictPut as Strict+import qualified Data.Binary.Get as Binary++data ARPPacket = ARPQuery ARPQueryPacket+               | ARPReply ARPReplyPacket+               deriving (Show, Eq)++data ARPQueryPacket = +  ARPQueryPacket { querySenderEthernetAddress :: EthernetAddress+                 , querySenderIPAddress       :: IPAddress+                 , queryTargetIPAddress       :: IPAddress+                 } deriving (Show,Eq)+++data ARPReplyPacket = +  ARPReplyPacket { replySenderEthernetAddress :: EthernetAddress+                 , replySenderIPAddress       :: IPAddress+                 , replyTargetEthernetAddress :: EthernetAddress+                 , replyTargetIPAddress       :: IPAddress+                 } +  deriving (Show, Eq)++queryOpCode, replyOpCode :: Word16+queryOpCode = 1+replyOpCode = 2+++-- | Parser for ARP packets+getARPPacket :: Strict.Get (Maybe ARPPacket)+getARPPacket = do +  htype <- Strict.getWord16be+  ptype <- Strict.getWord16be+  hlen  <- Strict.getWord8+  plen  <- Strict.getWord8+  opCode <- Strict.getWord16be+  sha <- getEthernetAddress+  spa <- getIPAddress+  tha <- getEthernetAddress+  tpa <- getIPAddress+  body <- if opCode == queryOpCode+          then return ( Just (ARPQuery (ARPQueryPacket { querySenderEthernetAddress = sha+                                                       , querySenderIPAddress       = spa+                                                       , queryTargetIPAddress       = tpa+                                                       } +                                       )+                             )+                      )+          else if opCode == replyOpCode +               then return (Just (ARPReply (ARPReplyPacket { replySenderEthernetAddress = sha+                                                           , replySenderIPAddress       = spa+                                                           , replyTargetEthernetAddress = tha+                                                           , replyTargetIPAddress       = tpa+                                                           } +                                           )+                                 )+                           )+               else return Nothing+  return body++-- | Parser for ARP packets+getARPPacket2 :: Binary.Get (Maybe ARPPacket)+getARPPacket2 = do +  htype <- Binary.getWord16be+  ptype <- Binary.getWord16be+  hlen  <- Binary.getWord8+  plen  <- Binary.getWord8+  opCode <- Binary.getWord16be+  sha <- getEthernetAddress2+  spa <- getIPAddress2+  tha <- getEthernetAddress2+  tpa <- getIPAddress2+  body <- if opCode == queryOpCode+          then return ( Just (ARPQuery (ARPQueryPacket { querySenderEthernetAddress = sha+                                                       , querySenderIPAddress       = spa+                                                       , queryTargetIPAddress       = tpa+                                                       } +                                       )+                             )+                      )+          else if opCode == replyOpCode +               then return (Just (ARPReply (ARPReplyPacket { replySenderEthernetAddress = sha+                                                           , replySenderIPAddress       = spa+                                                           , replyTargetEthernetAddress = tha+                                                           , replyTargetIPAddress       = tpa+                                                           } +                                           )+                                 )+                           )+               else return Nothing+  return body+++putARPPacket :: ARPPacket -> Strict.Put+putARPPacket body = +  case body of +    (ARPQuery (ARPQueryPacket {..})) -> +      do +        Strict.putWord16be ethernetHardwareType+        Strict.putWord16be ipProtocolType+        Strict.putWord8 numberOctetsInEthernetAddress+        Strict.putWord8 numberOctetsInIPAddress+        Strict.putWord16be queryOpCode+        putEthernetAddress querySenderEthernetAddress+        putIPAddress querySenderIPAddress+        putEthernetAddress (ethernetAddress 0 0 0 0 0 0)+        putIPAddress queryTargetIPAddress+        +    (ARPReply (ARPReplyPacket {..})) -> +      do +        Strict.putWord16be ethernetHardwareType+        Strict.putWord16be ipProtocolType+        Strict.putWord8 numberOctetsInEthernetAddress+        Strict.putWord8 numberOctetsInIPAddress+        Strict.putWord16be replyOpCode+        putEthernetAddress replySenderEthernetAddress+        putIPAddress replySenderIPAddress+        putEthernetAddress replyTargetEthernetAddress+        putIPAddress replyTargetIPAddress++ethernetHardwareType          = 1+ipProtocolType                = 0x0800+numberOctetsInEthernetAddress = 6+numberOctetsInIPAddress       = 4+
+ nettle-openflow/src/Nettle/Ethernet/EthernetAddress.hs view
@@ -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
+ nettle-openflow/src/Nettle/Ethernet/EthernetFrame.hs view
@@ -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+
+ nettle-openflow/src/Nettle/IPv4/IPAddress.hs view
@@ -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)
+ nettle-openflow/src/Nettle/IPv4/IPPacket.hs view
@@ -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)+
+ nettle-openflow/src/Nettle/OpenFlow.hs view
@@ -0,0 +1,33 @@+module Nettle.OpenFlow (+  module Nettle.OpenFlow.Action+  , module Nettle.OpenFlow.Error+  , module Nettle.OpenFlow.FlowTable+  , module Nettle.OpenFlow.Match+  , module Nettle.OpenFlow.Messages+  , module Nettle.OpenFlow.MessagesBinary+  , module Nettle.OpenFlow.Packet+  , module Nettle.OpenFlow.Port+  , module Nettle.OpenFlow.Statistics+  , module Nettle.OpenFlow.Switch+  , module Nettle.Ethernet.EthernetAddress+  , module Nettle.Ethernet.EthernetFrame+  , module Nettle.IPv4.IPAddress+  , module Nettle.IPv4.IPPacket+  , module Data.HList+  ) where++import Nettle.OpenFlow.Action+import Nettle.OpenFlow.Error+import Nettle.OpenFlow.FlowTable+import Nettle.OpenFlow.Match+import Nettle.OpenFlow.Messages+import Nettle.OpenFlow.MessagesBinary+import Nettle.OpenFlow.Packet+import Nettle.OpenFlow.Port+import Nettle.OpenFlow.Statistics+import Nettle.OpenFlow.Switch+import Nettle.Ethernet.EthernetAddress+import Nettle.Ethernet.EthernetFrame+import Nettle.IPv4.IPAddress+import Nettle.IPv4.IPPacket+import Data.HList
+ nettle-openflow/src/Nettle/OpenFlow/Action.hs view
@@ -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+++
+ nettle-openflow/src/Nettle/OpenFlow/Error.hs view
@@ -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)+
+ nettle-openflow/src/Nettle/OpenFlow/FlowTable.hs view
@@ -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)
+ nettle-openflow/src/Nettle/OpenFlow/Match.hs view
@@ -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
+ nettle-openflow/src/Nettle/OpenFlow/Messages.hs view
@@ -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)++
+ nettle-openflow/src/Nettle/OpenFlow/MessagesBinary.hs view
@@ -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]+++
+ nettle-openflow/src/Nettle/OpenFlow/Packet.hs view
@@ -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
+ nettle-openflow/src/Nettle/OpenFlow/Port.hs view
@@ -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)
+ nettle-openflow/src/Nettle/OpenFlow/Statistics.hs view
@@ -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
+ nettle-openflow/src/Nettle/OpenFlow/StrictPut.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}++-- | This module provides a monad for serializing data into byte strings. +-- It provides mostly the same interface that Data.Binary.Put does. +-- However, the implementation is different. It allows for the data to be+-- serialized into an existing array of Word8 values. This differs from the Data.Binary.Put+-- data type, which allocates a Word8 array every time a value is serialized. +-- This module's implementation is useful if you want to reuse the Word8 array for many serializations.+-- In the case of an OpenFlow server, we can reuse a buffer to send messages, since we have no use +-- for the the Word8 array, except to pass it to an IO procedure to write the data to a socket or file.+module Nettle.OpenFlow.StrictPut (+  PutM, +  Put, +  runPut, +  runPutToByteString,+  putWord8, +  putWord16be, +  putWord32be,+  putWord64be,+  putByteString+  ) where++import qualified Data.ByteString as S+import qualified Data.ByteString.Internal as S+import GHC.Word+import Foreign+import GHC.Exts+import System.IO.Unsafe++-- A state monad with state being the pointer to write location.+newtype PutM a = PutM { unPut :: Ptr Word8 -> IO (a, Ptr Word8) }++type Put = PutM ()++-- | Runs the Put writer with write position given+-- by the first pointer argument. Returns the number+-- of words written. +runPut :: Ptr Word8 -> Put -> IO Int+runPut ptr (PutM f) = +  do (_, ptr') <- f ptr+     return (ptr' `minusPtr` ptr)++-- | Allocates a new byte string, and runs the Put writer with that byte string. +-- The first argument is an upper bound on the size of the array needed to do the serialization.+runPutToByteString :: Int -> Put -> S.ByteString+runPutToByteString maxSize put = +  unsafeDupablePerformIO (S.createAndTrim maxSize (\ptr -> runPut ptr put))+  +instance Monad PutM where+  return x = PutM (\ptr -> return (x, ptr))+  {-# INLINE return #-}+  (PutM m) >>= f = PutM (\(!ptr) -> do { (a, ptr') <- m ptr ; let (PutM g) = f a in g ptr' } )+  {-# INLINE (>>=) #-}+  +putWord8 :: Word8 -> Put  +putWord8 !w = PutM (\(!ptr) -> do { poke ptr w; return ((), ptr `plusPtr` 1) })+{-# INLINE putWord8 #-}++putWord16be :: Word16 -> Put+putWord16be !w = PutM f+  where f !ptr = +          do poke ptr               (fromIntegral (shiftr_w16 w 8) :: Word8)+             poke (ptr `plusPtr` 1) (fromIntegral (w)              :: Word8)+             return ((), ptr `plusPtr` 2)+{-# INLINE putWord16be #-}++-- | Write a Word32 in big endian format+putWord32be :: Word32 -> Put+putWord32be !w = PutM f+  where f !p = +          do poke p               (fromIntegral (shiftr_w32 w 24) :: Word8)+             poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8)+             poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w  8) :: Word8)+             poke (p `plusPtr` 3) (fromIntegral (w)               :: Word8)+             return ((), p `plusPtr` 4)+{-# INLINE putWord32be #-}++-- | Write a Word64 in big endian format+putWord64be :: Word64 -> Put+#if WORD_SIZE_IN_BITS < 64+--+-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to+-- Word32, and write that+--+putWord64be !w =+    let a = fromIntegral (shiftr_w64 w 32) :: Word32+        b = fromIntegral w                 :: Word32+    in PutM $ \(!p) -> do+      poke p               (fromIntegral (shiftr_w32 a 24) :: Word8)+      poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8)+      poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a  8) :: Word8)+      poke (p `plusPtr` 3) (fromIntegral (a)               :: Word8)+      poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8)+      poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8)+      poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b  8) :: Word8)+      poke (p `plusPtr` 7) (fromIntegral (b)               :: Word8)+      return ((), p `plusPtr` 8)+#else+putWord64be !w = PutM $ \(!p) -> do+  poke p               (fromIntegral (shiftr_w64 w 56) :: Word8)+  poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8)+  poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8)+  poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8)+  poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8)+  poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8)+  poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w  8) :: Word8)+  poke (p `plusPtr` 7) (fromIntegral (w)               :: Word8)+  return ((), p `plusPtr` 8)+#endif+{-# INLINE putWord64be #-}++putByteString :: S.ByteString -> Put+putByteString !bs = PutM f+  where f !ptr =  +          let (fp, offset, len) = S.toForeignPtr bs+          in do withForeignPtr fp $ \bsptr -> S.memcpy ptr (bsptr `plusPtr` offset) (fromIntegral len)+                return ((), ptr `plusPtr` len)+                     +{-# INLINE putByteString #-}++{-# INLINE shiftr_w16 #-}+shiftr_w16 :: Word16 -> Int -> Word16+{-# INLINE shiftr_w32 #-}+shiftr_w32 :: Word32 -> Int -> Word32+{-# INLINE shiftr_w64 #-}+shiftr_w64 :: Word64 -> Int -> Word64+++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#`   i)+shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#`   i)++#if WORD_SIZE_IN_BITS < 64+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)+#endif+#endif
+ nettle-openflow/src/Nettle/OpenFlow/Switch.hs view
@@ -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)
+ nettle-openflow/src/Nettle/Servers/Client.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE BangPatterns #-}++-- | This module provides methods to connect to an OpenFlow control server, +-- and send and receive messages to the server.+module Nettle.Servers.Client+    (     +      ClientHandle      +      , connectToController+      , connectToHandles+      , closeClient+      , receiveControlMessage+      , sendMessage+      , flushClient+    ) where++import Network +import System.IO+import qualified Data.ByteString as S+import Data.Binary.Strict.Get+import Nettle.OpenFlow hiding (PortID)+import qualified Nettle.OpenFlow.StrictPut as Strict+import Data.Word+import Foreign++-- | Abstract type representing the state of the connection to the control server.+newtype ClientHandle = ClientHandle (Handle, Handle, ForeignPtr Word8)++-- | Established a connection to the control server with the given 'Network.HostName' +-- and 'Network.PortID' and returns its 'ClientHandle'.+connectToController :: HostName -> PortID -> IO ClientHandle+connectToController host port = +  do h <- connectTo host port+     hSetBuffering h (BlockBuffering (Just (4 * 1024)))+     connectToHandles h h++-- | Creates a 'ClientHandle' based on a handle to read from and one to write to.+connectToHandles :: Handle -> Handle -> IO ClientHandle+connectToHandles h h' = +  do let bufferSize = 32 * 1024+     outBufferPtr <- mallocForeignPtrBytes bufferSize :: IO (ForeignPtr Word8)+     return (ClientHandle (h,h',outBufferPtr))++-- | Close client, closing read and write handles.+closeClient :: ClientHandle -> IO ()+closeClient (ClientHandle (h,h',_)) = hClose h >> hClose h'++-- | Blocks until a new control message arrives or the connection is terminated, in which +-- the return value is 'Nothing'.+receiveControlMessage :: ClientHandle -> IO (Maybe (TransactionID, CSMessage))+receiveControlMessage (ClientHandle (h,_,_)) +  = do eof <- hIsEOF h+       if eof +         then return Nothing+         else do hdrbs <- S.hGet h headerSize+                 when (headerSize /= S.length hdrbs) (error "error reading header")+                 case fst (runGet getHeader hdrbs) of+                   Left err     -> error err+                   Right header -> +                     do let expectedBodyLen = fromIntegral (msgLength header) - S.length hdrbs+                        bodybs <- S.hGet h expectedBodyLen+                        when (expectedBodyLen /= S.length bodybs) (error "error reading body")+                        case fst (runGet (getCSMessageBody header) bodybs) of+                          Left err  -> error err+                          Right msg -> return (Just msg)+  where headerSize = 8        +{-# INLINE receiveControlMessage #-}+        +-- | Sends a message to the controller.        +sendMessage :: ClientHandle -> (TransactionID, SCMessage) -> IO ()+sendMessage (ClientHandle (_,h,fptr)) msg =+  withForeignPtr fptr $ \ptr -> +  do bytes <- Strict.runPut ptr (putSCMessage msg)+     hPutBuf h ptr bytes+{-# INLINE sendMessage #-}    +     +flushClient :: ClientHandle -> IO ()     +flushClient (ClientHandle (_,h,_)) = hFlush h++
+ nettle-openflow/src/Nettle/Servers/Server.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}++-- | Provides a simple, basic, and efficient server which provides methods+-- to listen for new switches to connect, and to receive and send OpenFlow+-- messages to switches. This server handles the initialization procedure with switches+-- and handles echo requests from switches.+module Nettle.Servers.Server+    (     +      -- * OpenFlow Server+      OpenFlowServer+      , ServerPortNumber +      , HostName+      , startOpenFlowServer+      , acceptSwitch +      , closeServer+        -- * Switch connection+      , SwitchHandle+      , handle2SwitchID+      , switchSockAddr+      , receiveFromSwitch+      , receiveBatch+      , sendToSwitch+      , sendBatch+      , sendBatches+      , sendToSwitchWithID+      , closeSwitchHandle+        -- * Utility+      , untilNothing+    ) where+++import Control.Exception+import Network.Socket hiding (recv)+import Network.Socket.ByteString (recv, sendAll, sendMany)+import qualified Data.ByteString as S+import System.IO+import Data.Binary.Strict.Get+import Nettle.OpenFlow+import qualified Nettle.OpenFlow.StrictPut as Strict+import Data.Word+import Foreign+import qualified Data.ByteString.Internal as S+import Data.Map (Map)+import qualified Data.Map as Map+import Text.Printf+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+
+ src/Benchmark.hs view
@@ -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
+ src/Frenetic/Common.hs view
@@ -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
+ src/Frenetic/Compat.hs view
@@ -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 ()+
+ src/Frenetic/EthernetAddress.hs view
@@ -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)
+ src/Frenetic/Hosts/Nettle.hs view
@@ -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+
+ src/Frenetic/NetCore.hs view
@@ -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
+ src/Frenetic/NetCore/Compiler.hs view
@@ -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+
+ src/Frenetic/NetCore/Pretty.hs view
@@ -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 "{field<sep>value; field<sep>value}"+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"
+ src/Frenetic/NetCore/Reduce.hs view
@@ -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
+ src/Frenetic/NetCore/Semantics.hs view
@@ -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
+ src/Frenetic/NetCore/Short.hs view
@@ -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}
+ src/Frenetic/NetCore/Types.hs view
@@ -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) = "<fwd=" ++ show (MS.toAscList fwd) ++ " q=" ++ show 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
+ src/Frenetic/NettleEx.hs view
@@ -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
+ src/Frenetic/NetworkFrames.hs view
@@ -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
+ src/Frenetic/Pattern.hs view
@@ -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
+ src/Frenetic/Server.hs view
@@ -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
+ src/Frenetic/Slices/Compile.hs view
@@ -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
+ src/Frenetic/Slices/Slice.hs view
@@ -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
+ src/Frenetic/Slices/VlanAssignment.hs view
@@ -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]
+ src/Frenetic/Switches/OpenFlow.hs view
@@ -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+
+ src/Frenetic/Topo.hs view
@@ -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
+ testsuite/Main.hs view
@@ -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+                                     ]