diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2010, Andreas Voellmy and Yale University +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +o Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +o Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +o Neither the name of the nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +# OpenFlow [![Build Status](https://travis-ci.org/AndreasVoellmy/openflow.svg)](https://travis-ci.org/AndreasVoellmy/openflow) + +OpenFlow is a Haskell library that implements OpenFlow protocols 1.0 and 1.3. It defines data types that model the logical content of the various OpenFlow protocol messages and provides serialization and deserialization methods using the [binary package](http://hackage.haskell.org/package/binary). It also provides basic functions to start servers that use these representations. + +# Contributors + +* Andreas Voellmy +* Ashish Agarwal +* John Launchbury diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/openflow.cabal b/openflow.cabal new file mode 100644 --- /dev/null +++ b/openflow.cabal @@ -0,0 +1,68 @@ +Name: openflow +Version: 0.3.0 +Synopsis: OpenFlow +Cabal-Version: >=1.10 +Build-Type: Simple +Stability: Experimental +Category: Network +License: OtherLicense +License-file: LICENSE +Author: Andreas Voellmy +Maintainer: Andreas Voellmy +homepage: https://github.com/AndreasVoellmy/openflow +Description: + This package implements the OpenFlow 1.0 and a large part of the OpenFlow 1.3 protocols. + It defines a collection of data types representing the logical contents of OpenFlow messages, + defines serialization and deserialization methods using the binary package, and provides some simple + servers that can be used with these data types. + +extra-source-files: Setup.hs README.md + +source-repository head + type: git + location: git://github.com/AndreasVoellmy/openflow.git + + + +library + exposed-modules: + Network.Data.Util + Network.Data.Ethernet + Network.Data.Ethernet.EthernetAddress + Network.Data.Ethernet.EthernetFrame + Network.Data.Ethernet.AddressResolutionProtocol + Network.Data.Ethernet.LLDP + Network.Data.IPv4 + Network.Data.IPv4.IPAddress + Network.Data.IPv4.IPPacket + Network.Data.IPv4.DHCP + Network.Data.IPv4.UDP + Network.Data.OpenFlow.Port + Network.Data.OpenFlow.Action + Network.Data.OpenFlow.Switch + Network.Data.OpenFlow.Match + Network.Data.OpenFlow.MatchBuilder + Network.Data.OpenFlow.FlowTable + Network.Data.OpenFlow.Statistics + Network.Data.OpenFlow.Error + Network.Data.OpenFlow.Packet + Network.Data.OpenFlow.Messages + Network.Data.OpenFlow.MessagesBinary + Network.Data.OpenFlow + + Network.Data.OF13.Message + Network.Data.OF13.Server + + ghc-options: -funbox-strict-fields -Wall + hs-source-dirs: src + default-language: Haskell2010 + build-depends: + aeson >= 0.7.0.6 && <= 0.9.0.1, + base >= 4.4.0.0 && <= 5, + bimap >= 0.2.4 && <= 0.3, + binary >= 0.7.0, + bytestring, + containers, + deepseq-generics >= 0.1.1.2, + hashable >= 1.2.1.0, + network >= 2.6.0.2 diff --git a/src/Network/Data/Ethernet.hs b/src/Network/Data/Ethernet.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/Ethernet.hs @@ -0,0 +1,12 @@ +module Network.Data.Ethernet + ( module Network.Data.Ethernet.EthernetAddress + , module Network.Data.Ethernet.EthernetFrame + , module Network.Data.Ethernet.AddressResolutionProtocol + , module Network.Data.Ethernet.LLDP + ) where + + +import Network.Data.Ethernet.EthernetAddress +import Network.Data.Ethernet.EthernetFrame +import Network.Data.Ethernet.AddressResolutionProtocol +import Network.Data.Ethernet.LLDP diff --git a/src/Network/Data/Ethernet/AddressResolutionProtocol.hs b/src/Network/Data/Ethernet/AddressResolutionProtocol.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/Ethernet/AddressResolutionProtocol.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE MultiParamTypeClasses, RecordWildCards, TypeOperators #-} + +module Network.Data.Ethernet.AddressResolutionProtocol ( + ARPPacket (..) + , ARPQueryPacket(..) + , ARPReplyPacket(..) + , arpOpCode + , getARPPacket + , putARPPacket + ) where + +import Network.Data.Ethernet.EthernetAddress +import Network.Data.IPv4.IPAddress +import Data.Word +import qualified Data.Binary.Get as Strict +import qualified Data.Binary.Put as Strict + +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) + +arpOpCode :: ARPPacket -> Word16 +arpOpCode (ARPQuery _) = queryOpCode +arpOpCode (ARPReply _) = replyOpCode + +queryOpCode, replyOpCode :: Word16 +queryOpCode = 1 +replyOpCode = 2 + + +-- | Parser for ARP packets +getARPPacket :: Strict.Get (Maybe ARPPacket) +getARPPacket = do + _ <- Strict.getWord16be + _ <- Strict.getWord16be + _ <- Strict.getWord8 + _ <- 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 + + +putARPPacket :: ARPPacket -> Strict.Put +putARPPacket body = + case body of + (ARPQuery (ARPQueryPacket {..})) -> + 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 {..})) -> + Strict.putWord16be ethernetHardwareType >> + Strict.putWord16be ipProtocolType >> + Strict.putWord8 numberOctetsInEthernetAddress >> + Strict.putWord8 numberOctetsInIPAddress >> + Strict.putWord16be replyOpCode >> + putEthernetAddress replySenderEthernetAddress >> + putIPAddress replySenderIPAddress >> + putEthernetAddress replyTargetEthernetAddress >> + putIPAddress replyTargetIPAddress + +ethernetHardwareType :: Word16 +ethernetHardwareType = 1 + +ipProtocolType :: Word16 +ipProtocolType = 0x0800 + +numberOctetsInEthernetAddress :: Word8 +numberOctetsInEthernetAddress = 6 + +numberOctetsInIPAddress :: Word8 +numberOctetsInIPAddress = 4 + diff --git a/src/Network/Data/Ethernet/EthernetAddress.hs b/src/Network/Data/Ethernet/EthernetAddress.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/Ethernet/EthernetAddress.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE DeriveGeneric #-} + +module Network.Data.Ethernet.EthernetAddress ( + -- * Ethernet address + EthernetAddress + , ethernetAddress + , ethernetAddress64 + , unpack + , unpack64 + , toList + , pack_32_16 + , isReserved + , broadcastAddress + , prettyPrintEthernetAddress + + -- * Parsers and unparsers + , getEthernetAddress + , putEthernetAddress + ) where + +import Data.Aeson +import Data.Word +import Data.Bits +import qualified Data.Binary.Get as Strict +import qualified Data.Binary.Put as Strict +import Numeric (showHex, readHex) +import Network.Data.Util +import GHC.Generics (Generic) +import Data.Hashable +import Data.Typeable +import Control.DeepSeq.Generics + +-- | An Ethernet address consists of 6 bytes. It is stored in a single 64-bit value. +newtype EthernetAddress = EthernetAddress Word64 + deriving ( Eq + , Ord + , Generic + , Typeable + , Bits + , Integral + , Real + , Enum + , Num + ) + +instance Hashable EthernetAddress +instance ToJSON EthernetAddress +instance FromJSON EthernetAddress +instance NFData EthernetAddress where rnf = genericRnf + +{- +prettyPrintEthernetAddress :: EthernetAddress -> String +prettyPrintEthernetAddress eth + = concat $ intersperse ":" (map (\n -> showHex n "") + [w0,w1,w2,w3,w4,w5]) + where (w0,w1,w2,w3,w4,w5) = unpack eth +-} +-- | 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 #-} + +-- | Unparse an Ethernet address to a ByteString +putEthernetAddress :: EthernetAddress -> Strict.Put +putEthernetAddress (EthernetAddress w64) + = do Strict.putWord32be (fromIntegral (shiftR w64 16)) + Strict.putWord16be (fromIntegral (w64 `mod` 0x010000)) +{-# INLINE putEthernetAddress #-} + +isReserved :: EthernetAddress -> Bool +isReserved e = + let (a1, a2, a3, a4, a5, _) = unpack e + in + a1 == 0x01 && + a2 == 0x80 && + a3 == 0xc2 && + a4 == 0 && + ((a5 .&. 0xf0) == 0) + +broadcastAddress :: EthernetAddress +broadcastAddress = EthernetAddress 0xffffffffffff + + +-- Show & Read instances +-- +-- Specifications: +-- (A) unConcatIntersperse c . concatIntersperse [c] == id +-- (B) parseHex1 . unparseHex1 == id +-- (C) fromList . toList == id +-- +-- Then, we reason: +-- +-- hexParseEthernetAddress . prettyPrintEthernetAddress +-- +-- { expanding definitions } +-- +-- == fromList . map parseHex1 +-- . unConcatIntersperse ':' . concatIntersperse ":" +-- . map (\n -> showHex n "") . toList +-- +-- { By prop (A) } +-- +-- == fromList . map parseHex1 . map unparseHex1 . toList +-- +-- { map-map fusion } +-- +-- == fromList . map (parseHex1 . unparseHex1) . toList +-- +-- { By prop (B) } +-- +-- == fromList . map id . toList +-- +-- { map functor law } +-- +-- == fromList . toList +-- +-- { By prop (C) } +-- +-- == id + +prettyPrintEthernetAddress :: EthernetAddress -> String +prettyPrintEthernetAddress = + concatIntersperse ":" . map unparseHex1 . toList + +hexParseEthernetAddress :: String -> EthernetAddress +hexParseEthernetAddress = fromList . hexParseWords + +hexParseWords :: String -> [Word8] +hexParseWords = map parseHex1 . unConcatIntersperse ':' + +parseHex1 :: String -> Word8 +parseHex1 = fst . head . readHex + +unparseHex1 :: Word8 -> String +unparseHex1 n + | n < 16 = '0' : showHex n "" + | otherwise = showHex n "" + +toList :: EthernetAddress -> [Word8] +toList eth = [w0,w1,w2,w3,w4,w5] + where (w0,w1,w2,w3,w4,w5) = unpack eth + +fromList :: [Word8] -> EthernetAddress +fromList [w0,w1,w2,w3,w4,w5] = ethernetAddress w0 w1 w2 w3 w4 w5 +fromList _ = error "Incorrect number of bytes to construct EthernetAddress." + +instance Show EthernetAddress where + show = prettyPrintEthernetAddress + +instance Read EthernetAddress where + readsPrec _ s = [(hexParseEthernetAddress s,"")] + diff --git a/src/Network/Data/Ethernet/EthernetFrame.hs b/src/Network/Data/Ethernet/EthernetFrame.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/Ethernet/EthernetFrame.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE BangPatterns #-} + +-- | This module provides data structures for Ethernet frames +-- as well as parsers and unparsers for Ethernet frames. +module Network.Data.Ethernet.EthernetFrame ( + + -- * Data types + EthernetFrame + , EthernetHeader(..) + , EthernetBody(..) + , EthernetTypeCode + , UnknownFrame(..) + , MagellanP4Packet(..) + + , lldpFrame + , typeCode + , ethTypeVLAN + , ethTypeIP + , ethTypeIPv6 + , ethType8021X + , ethTypeARP + , ethTypeLLDP + , ethTypeMagellanP4 + , typeEth2Cutoff + , VLANPriority + , VLANID + + -- * Parsers and unparsers + , getEthernetFrame + , getEthHeader + , putEthHeader + , putEthFrame + + -- * ARP frames + , arpQuery + , arpReply + + ) where + +import Data.Binary.Get (Get, getWord8, getWord16be) +import Data.Binary.Put (Put, putWord8, putWord16be, putByteString) +import Data.Bits (shiftL, shiftR, testBit, setBit, (.&.)) +import qualified Data.ByteString as S +import Data.Word (Word8, Word16) +import Network.Data.Ethernet.AddressResolutionProtocol +import Network.Data.Ethernet.EthernetAddress (EthernetAddress, getEthernetAddress, putEthernetAddress, broadcastAddress, ethernetAddress64) +import Network.Data.Ethernet.LLDP +import Network.Data.IPv4.IPAddress +import Network.Data.IPv4.IPPacket +import Text.Printf (printf) + +-- | 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) + +data EthernetHeader = EthernetHeader { etherDst :: !EthernetAddress, + etherSrc :: !EthernetAddress } + | Ethernet8021Q { etherDst :: !EthernetAddress, + etherSrc :: !EthernetAddress, + priorityCodePoint :: !VLANPriority, + canonicalFormatIndicator :: !Bool, + vlanId :: !VLANID } + deriving (Read,Show,Eq) + +-- | Ethernet type code, determines the type of payload carried by an Ethernet frame. +type EthernetTypeCode = Word16 + +type VLANID = Word16 +type VLANPriority = Word8 + +data EthernetBody = IPInEthernet !IPPacket + | ARPInEthernet !ARPPacket + | LLDPInEthernet !LLDPDU + | MagellanP4Packet MagellanP4Packet + | OtherEthernetBody UnknownFrame + deriving (Show,Eq) + +class IsEthernetBody a where + etherTypeCode :: a -> EthernetTypeCode + putEtherBody :: a -> Put + +data UnknownFrame = UnknownFrame !EthernetTypeCode !S.ByteString + deriving (Show,Read,Eq) + +data MagellanP4Packet = MagellanP4PacketIn Word8 EthernetFrame + | MagellanP4PacketOut (Either Word8 Word16) EthernetFrame + deriving (Show,Eq) + +instance IsEthernetBody UnknownFrame where + etherTypeCode (UnknownFrame c _) = c + putEtherBody (UnknownFrame _ body) = putByteString body + +instance IsEthernetBody MagellanP4Packet where + etherTypeCode _ = ethTypeMagellanP4 + putEtherBody (MagellanP4PacketIn ingress frame) = do + putWord8 1 + putWord8 ingress + putWord8 0 + putWord16be 0 + putEthFrame frame + putEtherBody (MagellanP4PacketOut out frame) = do + putWord8 2 + putWord8 0 + case out of + Left egress -> putWord8 egress >> putWord16be 0 + Right mcgroup -> putWord8 0 >> putWord16be mcgroup + putEthFrame frame + +getMagellanP4Packet :: Get MagellanP4Packet +getMagellanP4Packet = do + typ <- getWord8 + ingress <- getWord8 -- ingress + egr <- getWord8 -- egress + mc <- getWord16be -- mcgroup + frame <- getEthernetFrame + if typ == 1 + then return $ MagellanP4PacketIn ingress frame + else if typ == 2 + then let out = if mc == 0 + then Left egr + else Right mc + in return $ MagellanP4PacketOut out frame + else error $ "unexpected MagellanP4 packet type: " ++ show typ + +unknownFrameParser :: EthernetHeader -> EthernetTypeCode -> Get UnknownFrame +unknownFrameParser _ tcode = return (UnknownFrame tcode S.empty) +{-# INLINE unknownFrameParser #-} + +-- Internal +ethernetFrame :: EthernetHeader -> EthernetBody -> EthernetFrame +ethernetFrame hdr body = (hdr, body) + +-- | Make an LLDP frame +lldpFrame :: EthernetAddress -> LLDPDU -> EthernetFrame +lldpFrame src lldp = ethernetFrame hdr (LLDPInEthernet lldp) + where + multicastAddr = ethernetAddress64 0x0180c2000000 + hdr = EthernetHeader { etherDst = multicastAddr, etherSrc = src } + +arpQuery :: EthernetAddress -- ^ source hardware address + -> IPAddress -- ^ source IP address + -> IPAddress -- ^ target IP address + -> EthernetFrame +arpQuery sha spa tpa = (hdr, ARPInEthernet body) + where hdr = EthernetHeader { etherDst = broadcastAddress, etherSrc = sha } + 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 = (hdr, ARPInEthernet body) + where hdr = EthernetHeader { etherDst = tha, etherSrc = sha } + body = ARPReply $ ARPReplyPacket { replySenderEthernetAddress = sha + , replySenderIPAddress = spa + , replyTargetEthernetAddress = tha + , replyTargetIPAddress = tpa + } + +-- | Parser for Ethernet frames. +getEthernetFrame :: Get EthernetFrame +getEthernetFrame = do + let getOther = unknownFrameParser + (hdr, tc) <- getEthHeader + case tc of + _ | tc == ethTypeIP -> do ipPacket <- getIPPacket + return (hdr, IPInEthernet ipPacket) + | tc == ethTypeARP -> do mArpPacket <- getARPPacket + case mArpPacket of + Just arpPacket -> return (hdr, ARPInEthernet arpPacket) + Nothing -> error "failed parsing ARP packet" + | tc == ethTypeLLDP -> do lldp <- getLLDPDU + return (hdr, LLDPInEthernet lldp) + | tc == ethTypeMagellanP4 -> do p <- getMagellanP4Packet + return (hdr, MagellanP4Packet p) + | otherwise -> do a <- getOther hdr tc + return (hdr, OtherEthernetBody a) +{-# INLINE getEthernetFrame #-} + +getEthHeader :: Get (EthernetHeader, EthernetTypeCode) +getEthHeader = do + !dstAddr <- getEthernetAddress + !srcAddr <- getEthernetAddress + !tcode <- getWord16be + continue dstAddr srcAddr tcode + where + continue :: EthernetAddress -> EthernetAddress -> EthernetTypeCode -> Get (EthernetHeader, EthernetTypeCode) + continue dstAddr srcAddr tcode + | tcode < typeEth2Cutoff = fail (printf "unrecognized eth header %s %s %d" (show dstAddr) (show srcAddr) tcode) + | tcode == ethTypeVLAN = do x <- getWord16be + etherType <- getWord16be + let pcp = fromIntegral (shiftR x 13) + let cfi = testBit x 12 + let vid = x .&. 0x0fff + return (Ethernet8021Q dstAddr srcAddr pcp cfi vid, etherType) + | otherwise = return (EthernetHeader dstAddr srcAddr, tcode) +{-# INLINE getEthHeader #-} + + +-- | Unparser for Ethernet headers. +putEthHeader :: EthernetHeader -> EthernetTypeCode -> Put +putEthHeader (EthernetHeader dstAddr srcAddr) tcode = + putEthernetAddress dstAddr >> + putEthernetAddress srcAddr >> + putWord16be tcode +putEthHeader (Ethernet8021Q dstAddr srcAddr pcp cfi vid) tcode = + putEthernetAddress dstAddr >> + putEthernetAddress srcAddr >> + putWord16be ethTypeVLAN >> + putWord16be x >> + putWord16be tcode + where x = let y = shiftL (fromIntegral pcp :: Word16) 13 + y' = if cfi then setBit y 12 else y + in y' + fromIntegral vid + +putEthFrame :: EthernetFrame -> Put +putEthFrame (hdr, body) = case body of + IPInEthernet ip -> putEthHeader hdr ethTypeIP >> putIP ip + ARPInEthernet arpPacket -> putEthHeader hdr ethTypeARP >> putARPPacket arpPacket + LLDPInEthernet lldp -> putEthHeader hdr ethTypeLLDP >> putLLDPDU lldp + MagellanP4Packet a -> putEthHeader hdr (etherTypeCode a) >> putEtherBody a + OtherEthernetBody a -> putEthHeader hdr (etherTypeCode a) >> putEtherBody a + +ethTypeIP, ethTypeIPv6, ethType8021X, ethTypeARP, ethTypeLLDP, ethTypeVLAN, typeEth2Cutoff, ethTypeMagellanP4 :: EthernetTypeCode +ethTypeIP = 0x0800 +ethTypeIPv6 = 0x86DD +ethType8021X = 0x888E +ethTypeARP = 0x0806 +ethTypeLLDP = 0x88CC +ethTypeVLAN = 0x8100 +typeEth2Cutoff = 0x0600 +ethTypeMagellanP4 = 0x9999 + + +typeCode :: EthernetBody -> EthernetTypeCode +typeCode (IPInEthernet _) = ethTypeIP +typeCode (ARPInEthernet _) = ethTypeARP +typeCode (LLDPInEthernet _) = ethTypeLLDP +typeCode (MagellanP4Packet _ ) = ethTypeMagellanP4 +typeCode (OtherEthernetBody a) = etherTypeCode a diff --git a/src/Network/Data/Ethernet/LLDP.hs b/src/Network/Data/Ethernet/LLDP.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/Ethernet/LLDP.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE BangPatterns #-} + +-- | This module defines the data type of LLDP messages and defines LLDP parser +-- and serialization functions. This module is very, very far from complete. +-- In particular it parses only LLDP messages that contain only the three +-- mandatory time-length-value (TLV) structures, namely Chassis ID, Port ID +-- and Time-To-Live (TTL) TLVs. In addition, both the ChassisID and Port ID +-- TLVs have multiple variants, but we only support a single variant in both +-- of these TLVs. +-- +-- This was developed according to reference IEEE Std 802.1AB-2009. +module Network.Data.Ethernet.LLDP + ( + LLDPDU ( .. ) + , ChassisID + , TLVPortID + , PortIDSubType(..) + , TTL + , getLLDPDU + , putLLDPDU + ) where + +import Data.Word +import Data.Binary.Get +import Data.Binary.Put +import qualified Data.ByteString as B +import Control.Exception (assert) +import Data.Bits (shiftR, shiftL, (.&.), (.|.)) +import Text.Printf (printf) + +-- | An LLDP Data Unit (LLDP) consists of three values: chassis id, port id, +-- and time-to-live. +data LLDPDU = LLDPDU { chassisIDTLV :: !ChassisID + , portIDTLV :: !(PortIDSubType, TLVPortID) + , timeToLiveTLV :: !TTL + } deriving (Eq, Show) + +type TLVType = Word8 +type TLVLength = Word16 + +getTLVHeader :: Get (TLVType, TLVLength) +getTLVHeader = + do !x <- getWord16be + let !tlvType = fromIntegral (shiftR x 9) :: Word8 + let !tlvLen = x .&. typeMask + return (tlvType, tlvLen) + +typeMask :: Word16 +typeMask = 2 ^ (9 :: Int) - 1 + +putTLVHeader :: TLVType -> TLVLength -> Put +putTLVHeader tlvType tlvLen + = let x = shiftL (fromIntegral tlvType) 9 :: Word16 + y = tlvLen .&. typeMask + z = x .|. y + in putWord16be z + +type ChassisID = B.ByteString +type ChassisIDSubType = Word8 + +getChassisIDTLV :: Get ChassisID +getChassisIDTLV = + do (!tlvType,!tlvLen) <- getTLVHeader + assert (tlvType == 1) $ + do cidSubType <- getWord8 + cid <- getChassisID tlvLen cidSubType + return cid + +getChassisID :: TLVLength -> ChassisIDSubType -> Get ChassisID +getChassisID tlvLen cidSubType + | cidSubType == 4 = do bs <- getByteString (fromIntegral tlvLen - 1) + return bs + | otherwise = fail $ + printf + "No support for Chassis TLV with subtype %d and length %d." + cidSubType + tlvLen + +putChassisIDTLV :: ChassisID -> Put +putChassisIDTLV cid = + assert (B.length cid == 8) $ + putTLVHeader 1 9 >> + putWord8 4 >> + putByteString cid + +type TLVPortID = B.ByteString +type PortIDSubTypeCode = Word8 +data PortIDSubType = InterfaceAlias + | PortComponent + | MACAddress + | NetworkAddress + | InterfaceName + | AgentCircuitID + | LocallyAssigned + | Reserved + deriving (Show,Read,Eq,Ord,Enum) + +portIDSubTypeCode_2_type :: PortIDSubTypeCode -> PortIDSubType +portIDSubTypeCode_2_type c + | c == 1 = InterfaceAlias + | c == 2 = PortComponent + | c == 3 = MACAddress + | c == 4 = NetworkAddress + | c == 5 = InterfaceName + | c == 6 = AgentCircuitID + | c == 7 = LocallyAssigned + | otherwise = Reserved + +portIDSubType_2_code :: PortIDSubType -> PortIDSubTypeCode +portIDSubType_2_code t = case t of + InterfaceAlias -> 1 + PortComponent -> 2 + MACAddress -> 3 + NetworkAddress -> 4 + InterfaceName -> 5 + AgentCircuitID -> 6 + LocallyAssigned -> 7 + Reserved -> 0 + +getPortIDTLV :: Get (PortIDSubType, TLVPortID) +getPortIDTLV = + do (!tlvType,!tlvLen) <- getTLVHeader + assert (tlvType == 2) $ + do pidSubType <- getWord8 + getPortID tlvLen pidSubType + +getPortID :: TLVLength -> PortIDSubTypeCode -> Get (PortIDSubType, TLVPortID) +getPortID tlvLen pidSubType = do + bs <- getByteString (fromIntegral tlvLen - 1) + return (portIDSubTypeCode_2_type pidSubType, bs) + +putPortID :: (PortIDSubType, TLVPortID) -> Put +putPortID (typ,pid) = + assert (B.length pid == 2 && typ == LocallyAssigned) $ + putTLVHeader 2 3 >> + putWord8 (portIDSubType_2_code LocallyAssigned) >> + putByteString pid + +type TTL = Word16 + +getTTLTLV :: Get TTL +getTTLTLV = do + (!tlvType,!tlvLen) <- getTLVHeader + assert (tlvType == 3 && tlvLen == 2) getWord16be + +putTTLTLV :: TTL -> Put +putTTLTLV ttl = putTLVHeader 3 2 >> putWord16be ttl + +getEndTLV :: Get () +getEndTLV = do x <- getWord16be + assert (x == 0) $ return () + +putEndTLV :: Put +putEndTLV = putWord16be 0 + +-- | Parser for LLDPDU messages; i.e. this parses the body of an Ethernet frame +-- that contains an LLDP message. +getLLDPDU :: Get LLDPDU +getLLDPDU = do + cid <- getChassisIDTLV + pid <- getPortIDTLV + ttl <- getTTLTLV + getEndTLV + return LLDPDU { chassisIDTLV = cid + , portIDTLV = pid + , timeToLiveTLV = ttl + } + +-- | Serialization method for LLDPDU messages; i.e. this serializes the body +-- of an Ethernet frame carrying an LLDP message. +putLLDPDU :: LLDPDU -> Put +putLLDPDU LLDPDU { chassisIDTLV = cid, portIDTLV = pid, timeToLiveTLV = ttl } + = putChassisIDTLV cid >> putPortID pid >> putTTLTLV ttl >> putEndTLV diff --git a/src/Network/Data/IPv4.hs b/src/Network/Data/IPv4.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/IPv4.hs @@ -0,0 +1,7 @@ +module Network.Data.IPv4 ( + module Network.Data.IPv4.IPAddress + , module Network.Data.IPv4.IPPacket + ) where + +import Network.Data.IPv4.IPAddress +import Network.Data.IPv4.IPPacket diff --git a/src/Network/Data/IPv4/DHCP.hs b/src/Network/Data/IPv4/DHCP.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/IPv4/DHCP.hs @@ -0,0 +1,36 @@ +module Network.Data.IPv4.DHCP + ( + DHCPMessage(..) + , getDHCPMessage + , dhcpServerPort + , dhcpClientPort + ) + where + +import Data.Binary.Get +import Network.Data.IPv4.UDP +import Network.Data.IPv4.IPAddress + +data DHCPMessage = DHCPDiscover + | DHCPMessageOther + deriving (Show,Eq) + +getDHCPMessage :: IPAddress + -> IPAddress + -> UDPPortNumber + -> UDPPortNumber + -> Get DHCPMessage +getDHCPMessage sa da sp dp = do + opcode <- getWord8 + if opcode == 1 && + sa == ipAddress 0 0 0 0 && da == ipAddress 255 255 255 255 && + sp == dhcpClientPort && dp == dhcpServerPort + then return DHCPDiscover + else return DHCPMessageOther + +dhcpServerPort :: UDPPortNumber +dhcpServerPort = 67 + +dhcpClientPort :: UDPPortNumber +dhcpClientPort = 68 + diff --git a/src/Network/Data/IPv4/IPAddress.hs b/src/Network/Data/IPv4/IPAddress.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/IPv4/IPAddress.hs @@ -0,0 +1,185 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} +module Network.Data.IPv4.IPAddress + ( + IPAddress(..) + , IPAddressPrefix + , PrefixLength + , showOctets + , addressToOctets + , ipAddressToWord32 + , ipAddress + , getIPAddress + , putIPAddress + , exactPrefix + , (//) + , addressPart + , prefixLength + , prefixToMask + , prefixLengthToMask + , maskToPrefixLength + , prefixIsExact + , defaultIPPrefix + , showPrefix + , prefixPlus + , prefixOverlaps + , elemOfPrefix + , intersect + , intersects + , disjoint + , disjoints + , isSubset + ) where + +import Data.Word +import Data.Bits +import Data.Maybe +import Data.Binary.Get +import qualified Data.Binary.Put as Strict +import Network.Data.Util +import GHC.Generics (Generic) +import Data.Hashable +import Control.DeepSeq.Generics + +import Data.Aeson.TH + +newtype IPAddress = IPAddress Word32 + deriving ( Eq + , Ord + , Generic + , Bits + , Integral + , Real + , Enum + , Num + ) + +instance Hashable IPAddress +instance NFData IPAddress where rnf = genericRnf + +$(deriveJSON defaultOptions ''IPAddress) + +instance Show IPAddress where + show = concatIntersperse "." . map show . addressToList + +instance Read IPAddress where + readsPrec _ s = [(readOctets s,"")] + +readOctets :: String -> IPAddress +readOctets = listToAddress . map read . unConcatIntersperse '.' + +showOctets :: IPAddress -> String +showOctets = show + +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 #-} + +putIPAddress :: IPAddress -> Strict.Put +putIPAddress (IPAddress a) = Strict.putWord32be a + +exactPrefix :: IPAddress -> IPAddressPrefix +exactPrefix !a = (a, 32) +{-# INLINE exactPrefix #-} + +(//) :: IPAddress -> PrefixLength -> IPAddressPrefix +(IPAddress a) // len + = let !a' = a .&. mask + !mask = complement (2^((32::Int) - fromIntegral len) - 1) + in (IPAddress a', len) + +addressPart :: IPAddressPrefix -> IPAddress +addressPart (a,_) = a +{-# INLINE addressPart #-} + +prefixLength :: IPAddressPrefix -> PrefixLength +prefixLength (_,l) = l +{-# INLINE prefixLength #-} + +prefixLengthToMask :: Int -> IPAddress +prefixLengthToMask l = IPAddress $ foldr (flip setBit) 0 [31,30..(32 - l)] + +prefixToMask :: IPAddressPrefix -> IPAddress +prefixToMask (_ , l) = prefixLengthToMask $ fromIntegral l + +maskToPrefixLength :: IPAddress -> Word8 +maskToPrefixLength (IPAddress w) = fromIntegral $ popCount w + +maxPrefixLen :: Word8 +maxPrefixLen = 32 + +prefixIsExact :: IPAddressPrefix -> Bool +prefixIsExact (_,l) = l==maxPrefixLen + +defaultIPPrefix :: IPAddressPrefix +defaultIPPrefix = (IPAddress 0, 0) + +addressToOctets :: IPAddress -> (Word8, Word8, Word8, Word8) +addressToOctets (IPAddress addr) = (b1,b2,b3,b4) + where b4 = fromIntegral $ addr .&. (2 ^ (8::Int) - 1) + b3 = fromIntegral $ shiftR (addr .&. (2 ^ (16::Int) - 1)) 8 + b2 = fromIntegral $ shiftR (addr .&. (2 ^ (24::Int) - 1)) 16 + b1 = fromIntegral $ shiftR (addr .&. (2 ^ (32::Int) - 1)) 24 + +addressToList :: IPAddress -> [Word8] +addressToList addr = + let (b1,b2,b3,b4) = addressToOctets addr + in [b1,b2,b3,b4] + +listToAddress :: [Word8] -> IPAddress +listToAddress [b1,b2,b3,b4] = ipAddress b1 b2 b3 b4 +listToAddress _ = error "incorrect number of bytes provided; expecting 4." + +showPrefix :: IPAddressPrefix -> String +showPrefix (addr, len) = show addr ++ "/" ++ show len + +prefixPlus :: IPAddressPrefix -> Word32 -> IPAddress +prefixPlus (IPAddress addr,_) x = IPAddress (addr + x) + +prefixOverlaps :: IPAddressPrefix -> IPAddressPrefix -> Bool +prefixOverlaps (IPAddress addr, len) (IPAddress addr', len') + | addr .&. mask == addr' .&. mask = True + | otherwise = False + where len'' = min len len' + -- mask = foldl setBit (0 :: Word32) [(32 - fromIntegral len'')..31] + -- !mask = complement (2^(32 - fromIntegral len'') - 1) + !mask = complement (2^(32 - len'') - 1) + +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 p1 p2 is True iff p2 is a subset of p1. +-- The order of the arguments seems unintuitive. +isSubset :: IPAddressPrefix -> IPAddressPrefix -> Bool +isSubset p1@(_,l) p2@(_,l') = l <= l' && (p1 `prefixOverlaps` p2) + diff --git a/src/Network/Data/IPv4/IPPacket.hs b/src/Network/Data/IPv4/IPPacket.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/IPv4/IPPacket.hs @@ -0,0 +1,246 @@ +{-# 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 Network.Data.IPv4.IPPacket ( + -- * IP Packet + IPPacket + , IPHeader(..) + , DifferentiatedServicesCodePoint + , FragOffset + , IPProtocol + , IPTypeOfService + , TransportPort + , ipProtocol + , ipBodyLength + , ipTypeTcp + , ipTypeUdp + , ipTypeIcmp + , IPBody(..) + + -- * Parsers + , getIPPacket + , getIPHeader + , ICMPHeader + , ICMPType + , ICMPCode + , getICMP + , TCPHeader + , TCPPortNumber + , getTCPHeader + , UDPHeader + , UDPPortNumber + , getUDPHeader + , putIP + , csum16 + ) where + +import Network.Data.IPv4.IPAddress +-- import Network.Data.IPv4.DHCP +import Network.Data.IPv4.UDP +import Data.Bits +import Data.Word +import Data.Binary.Get +import Data.Binary.Put +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Control.Exception (assert) + +-- | An IP packet consists of a header and a body. +type IPPacket = (IPHeader, IPBody) + +-- | 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 + , headerLength :: !Int + , totalLength :: !Int + , dscp :: !DifferentiatedServicesCodePoint -- ^ differentiated services code point - 6 bit number + , ecn :: !Word8 -- Explicit congestion notification (ECN); 2 bits. + , ttl :: !Word8 -- ^ time-to-live. + , ipChecksum :: !Word16 + , ident :: !Word16 + , flags :: !Word16 + } + deriving (Read,Show,Eq) + +type DifferentiatedServicesCodePoint = Word8 +type FragOffset = Word16 +type IPProtocol = Word8 +type IPTypeOfService = Word8 +type TransportPort = Word16 + +ipProtocol :: IPBody -> IPProtocol +ipProtocol (TCPInIP _ _) = ipTypeTcp +ipProtocol (UDPInIP _ _) = ipTypeUdp +ipProtocol (ICMPInIP _ _ _) = ipTypeIcmp +ipProtocol (UninterpretedIPBody proto) = proto +{-# INLINE ipProtocol #-} + +ipBodyLength :: IPHeader -> Int +ipBodyLength (IPHeader {..}) + = totalLength - (4 * headerLength) +{-# INLINE ipBodyLength #-} + +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 !TCPPortNumber !TCPPortNumber + | UDPInIP !UDPPortNumber !UDPPortNumber + | ICMPInIP !ICMPHeader B.ByteString Word16 + | UninterpretedIPBody !IPProtocol + deriving (Show,Eq) + + +getIPHeader :: Get (IPHeader, IPProtocol) +getIPHeader = do + b1 <- getWord8 + let version = shiftR b1 4 + assert (version == 4) $ do + diffServ <- getWord8 + totalLen <- getWord16be + ident <- getWord16be -- ident + flags <- getWord16be -- flagsAndFragOffset + ttl <- getWord8 -- ttl + nwproto <- getIPProtocol + ipChecksum <- getWord16be -- hdrChecksum + nwsrc <- getIPAddress + nwdst <- getIPAddress + let hdrLen = fromIntegral (b1 .&. 0x0f) + skip (max 0 (4 * (hdrLen - 5))) + return (IPHeader { ipSrcAddress = nwsrc + , ipDstAddress = nwdst + , headerLength = hdrLen + , totalLength = fromIntegral totalLen + , dscp = shiftR diffServ 2 + , ecn = diffServ .&. 3 + , ttl = ttl + , ipChecksum = ipChecksum + , ident = ident + , flags = flags + }, nwproto) +{-# INLINE getIPHeader #-} + +getIPProtocol :: Get IPProtocol +getIPProtocol = getWord8 +{-# INLINE getIPProtocol #-} + +getIPPacket :: Get IPPacket +getIPPacket = getIPHeader >>= getIPBody +{-# INLINE getIPPacket #-} + +getIPBody :: (IPHeader, IPProtocol) -> Get IPPacket +getIPBody (hdr@(IPHeader {..}), nwproto) + | nwproto == ipTypeTcp = do (s,d) <- getTCPHeader (ipBodyLength hdr) + return (hdr, TCPInIP s d) + | nwproto == ipTypeUdp = do (s,d) <- getUDPHeader + skip $ ipBodyLength hdr - 4 + let bdy = UDPInIP s d + return (hdr, bdy) + | nwproto == ipTypeIcmp = do (icmpHdr, bs, check) <- getICMP (ipBodyLength hdr) + return (hdr, ICMPInIP icmpHdr bs check) + | otherwise = return (hdr, UninterpretedIPBody nwproto) +{-# INLINE getIPBody #-} + +-- ipChecksum_ :: IPHeader -> Word8 -> Word16 +-- ipChecksum_ hdr nwproto = csum16 $ runPut $ putIPHeader hdr nwproto 0 + +csum16 :: L.ByteString -> Word16 +csum16 bs = complement $ x + y + where + x, y :: Word16 + x = fromIntegral (shiftR (z .&. 0xff00) 8) + y = fromIntegral (z .&. 0x00ff) + z :: Word32 + z = foldl (+) 0 ws + ws :: [Word32] + ws = runGet (sequence $ replicate (fromIntegral (L.length bs) `div` 4) getWord32be) bs + +putIP :: IPPacket -> Put +putIP (hdr, body) = do + let nwproto = ipProtocol body + putIPHeader hdr nwproto $ ipChecksum hdr --(ipChecksum hdr nwproto) + putIPBody (ipBodyLength hdr) body + +putIPHeader :: IPHeader -> Word8 -> Word16 -> Put +putIPHeader (IPHeader {..}) nwproto chksum = do + putWord8 b1 + putWord8 diffServ + putWord16be $ fromIntegral totalLength + putWord16be ident -- identification + putWord16be flags -- flags and offset + putWord8 ttl + putWord8 nwproto + putWord16be chksum + putIPAddress ipSrcAddress + putIPAddress ipDstAddress + -- assume no options. + where + b1 = shiftL vERSION_4 4 .|. fromIntegral headerLength + diffServ = shiftL dscp 2 .|. ecn + +vERSION_4 :: Word8 +vERSION_4 = 4 + +putIPBody :: Int -> IPBody -> Put +putIPBody _ (ICMPInIP (icmpType, icmpCode) bs check) = do + putWord8 icmpType + putWord8 icmpCode + putWord16be check -- $ csum16 $ L.fromStrict bs to L.pack [icmpType, icmpCode] + -- putWord16be $ csum16 $ L.append (L.pack [icmpType, icmpCode]) (L.fromStrict bs) + +-- L.fromStrict bs to L.pack [icmpType, icmpCode] + putByteString bs +putIPBody _ body = error $ "putIPBody: not yet handling IP body: " ++ show body + +-- Transport Header +type ICMPHeader = (ICMPType, ICMPCode) +type ICMPType = Word8 +type ICMPCode = Word8 + +getICMP :: Int -> Get (ICMPHeader, B.ByteString, Word16) +getICMP len = do + icmp_type <- getWord8 + icmp_code <- getWord8 + check <- getWord16be + bs <- getByteString $ len - 4 + return ((icmp_type, icmp_code), bs, check) +{-# INLINE getICMP #-} + + +type TCPHeader = (TCPPortNumber, TCPPortNumber) +type TCPPortNumber = Word16 + +getTCPHeader :: Int -> Get TCPHeader +getTCPHeader len = do + srcp <- getWord16be + dstp <- getWord16be + skip $ len - 4 + return (srcp,dstp) +{-# INLINE getTCPHeader #-} diff --git a/src/Network/Data/IPv4/UDP.hs b/src/Network/Data/IPv4/UDP.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/IPv4/UDP.hs @@ -0,0 +1,21 @@ +module Network.Data.IPv4.UDP + ( + UDPHeader + , UDPPortNumber + , getUDPHeader + ) where + +import Data.Binary.Get +import Data.Word + +type UDPHeader = (UDPPortNumber, UDPPortNumber) +type UDPPortNumber = Word16 + +getUDPHeader :: Get UDPHeader +getUDPHeader = do + srcp <- getWord16be + dstp <- getWord16be + return (srcp,dstp) +{-# INLINE getUDPHeader #-} + + diff --git a/src/Network/Data/OF13/Message.hs b/src/Network/Data/OF13/Message.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/OF13/Message.hs @@ -0,0 +1,1948 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.Data.OF13.Message ( + Message(..) + , XID + , TableID + , ErrorType(..) + , BadRequestError(..) + , SwitchCapability(..) + , ConfigFlag(..) + , Action(..) + , Match(..) + , OXM(..) + , OXMOFField(..) + , Instruction(..) + , PortID + , Priority + , oFPP_CONTROLLER + , Group(..) + , GroupID + , ActionList + , FailoverBucket(..) + , BucketWeight + , oFPG_MAX + , oFPG_ALL + , oFPG_ANY + , MeterID + , MPLSLabel + , IPv6FlowLabel + , IPv6Address + , STCPPort + , UDPPort + , TCPPort + , VLANMatch + , QueueID + , Header + , TableFeature(..) + , MultipartMessage(..) + , Port(..) + , PortFeature(..) + , PortConfigFlag(..) + , PortStats(..) + , PortStateChangeReason(..) + , Timeout + , Cookie + , TableStats(..) + , TableProperty(..) + , FlowRemovedReason(..) + , SwitchID + , Len + , BadMatchError(..) + , BadInstructionError(..) + , BadGroupModError(..) + , PacketInReason(..) + , KiloBitsPerSecond + , PortStateFlag + , isPortDown + , isPortUp + ) where + +import Network.Data.Ethernet hiding + (getEthernetAddress, putEthernetAddress) +import Network.Data.IPv4.IPAddress hiding (getIPAddress, putIPAddress) + +import Control.Applicative +import Control.Exception hiding (mask) +import Control.Monad +import Data.Bimap (Bimap) +import qualified Data.Bimap as Bimap +import Data.Binary +import Data.Binary.Get +import Data.Binary.Put +import Data.Bits +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import Data.Maybe (fromJust) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map +-- import qualified Debug.Trace as Debug + + +data Message = Hello { xid :: XID, len :: Len } + | EchoRequest { xid :: XID, body :: B.ByteString } + | EchoReply { xid :: XID, body :: B.ByteString } + | Error { xid :: XID + , body :: B.ByteString + , errorType :: ErrorType + , errorCode :: Word16 + } + | FeatureRequest { xid :: XID } + | FeatureReply { xid :: XID + , sid :: SwitchID + , numBuffers :: Word32 + , numTables :: Word8 + , auxID :: Word8 + , capabilities :: Set SwitchCapability + } + | ConfigRequest { xid :: XID } + | ConfigReply { xid :: XID + , configFlags :: Set ConfigFlag + , missSendLen :: Word16 + } + | ConfigSet { xid :: XID + , configFlags :: Set ConfigFlag + , missSendLen :: Word16 + } + | PacketIn { xid :: XID + , bufferID :: Maybe Word32 + , totalLen :: Word16 + , reason :: PacketInReason + , tableID :: TableID + , cookie :: Cookie + , match :: Match + , payload :: B.ByteString + } + | FlowRemoved { xid :: XID + , cookie :: Cookie + , priority :: Priority + , flowRemovedReason :: FlowRemovedReason + , tableID :: TableID + , duration_sec :: Word32 + , duration_nsec :: Word32 + , idleTimeout :: Timeout + , hardTimeout :: Timeout + , packetCount :: Word64 + , byteCount :: Word64 + , match :: Match + } + | PortStatus { xid :: XID + , portStateChangeReason :: PortStateChangeReason + , port :: Port + } + | PacketOut { xid :: XID + , packetOutBufferID :: Maybe Word32 + , inPort :: Maybe PortID + , actions :: [Action] + , payload :: B.ByteString + } + | AddFlow { xid :: XID + , cookie :: Cookie + , tableID :: TableID + , idleTimeout :: Timeout + , hardTimeout :: Timeout + , priority :: Priority + , bufferID :: Maybe Word32 + , sendFlowRemoved :: Bool + , checkOverlap :: Bool + , countPackets :: Bool + , countBytes :: Bool + , match :: Match + , instructions :: [Instruction] + } + | DeleteFlowStrict { xid :: XID + , cookie :: Cookie + , tableID :: TableID + , priority :: Priority + , outPort :: Maybe PortID + , outGroup :: Maybe GroupID + , match :: Match + } + | DeleteFlow { xid :: XID + , cookie :: Cookie + , cookieMask :: Cookie + , maybeTableID :: Maybe TableID + , priority :: Priority + , outPort :: Maybe PortID + , outGroup :: Maybe GroupID + , match :: Match + } + | ModifyFlowStrict { xid :: XID + , cookie :: Cookie + , tableID :: TableID + , priority :: Priority + , match :: Match + , resetCounters :: Bool + , instructions :: [Instruction] + } + | ModifyFlow { xid :: XID + , cookie :: Cookie + , cookieMask :: Cookie + , tableID :: TableID + , match :: Match + , resetCounters :: Bool + , instructions :: [Instruction] + } + | AddGroup { xid :: XID + , group :: Group + , groupID :: GroupID + } + | ModifyGroup { xid :: XID + , group :: Group + , groupID :: GroupID + } + | DeleteGroup { xid :: XID + , groupID :: GroupID + } + | PortMod { xid :: XID + , portID :: PortID + , hwAddr :: EthernetAddress + , portModConfig :: Map PortConfigFlag Bool + , portModAdvertised :: Set PortFeature + } + | RequestSwitchDesc { xid :: XID } + | RequestTableStats { xid :: XID } + | RequestPortStats { xid :: XID + , portID :: PortID + } + | RequestTableFeatures { xid :: XID + , tableFeatures :: [TableFeature] + } + | RequestPorts { xid :: XID } + | RequestGroups { xid :: XID } + | MultipartReply { xid :: XID + , moreToCome :: Bool + , multipartMessage :: MultipartMessage + } + | BarrierRequest { xid :: XID } + | BarrierReply { xid :: XID } + | Undefined Header + deriving (Show,Eq) + +type MultipartTypeCode = Word16 + +oFPMP_TABLE_FEATURES :: MultipartTypeCode +oFPMP_TABLE_FEATURES = 12 + +data TableFeature = TableFeature { tableFeatureTableID :: TableID + , tableName :: String -- len <= 32 + , metadataMatch :: Word64 + , metadataWrite :: Word64 + , maxEntries :: Int + , tableProperties :: [TableProperty] + } deriving (Eq,Show,Ord) + +data TableProperty = NoTableProperty --InstructionsProperty { } + deriving (Show,Eq,Ord) + +type Timeout = Word16 +type TableID = Word8 +type Priority = Word16 + +data Instruction = GotoTable TableID + | WriteMetadata { metadata :: Word64, metadataMask :: Word64 } + | WriteActions [Action] + | ApplyActions [Action] + | ClearActions + | Meter MeterID + deriving (Show,Eq) + +type MeterID = Word32 + +oFPP_CONTROLLER, oFPP_ANY :: PortID +oFPP_CONTROLLER = 0xfffffffd +oFPP_ANY = 0xffffffff + +oFPG_MAX, oFPG_ALL, oFPG_ANY :: GroupID +oFPG_MAX = 0xffffff00 +oFPG_ALL = 0xfffffffc +oFPG_ANY = 0xffffffff + +type ActionList = [Action] + +data Group = + All { buckets :: [ActionList] } + | Select { weightedBuckets :: [(BucketWeight, ActionList)] } + | Indirect { bucket :: ActionList } + | FastFailover { failoverBuckets :: [FailoverBucket] } + deriving (Eq,Show,Ord) + +type BucketWeight = Word16 +data FailoverBucket = FailoverBucket { bucketActions :: ActionList + , watchPort :: PortID + , watchGroup :: GroupID + } + deriving (Eq,Ord,Show) + +type GenericBucket = (BucketWeight, PortID, GroupID, ActionList) + +genericBuckets :: Group -> [GenericBucket] +genericBuckets (All {buckets}) = [(0, oFPP_ANY, oFPG_ANY, b) | b <- buckets ] +genericBuckets (Select { weightedBuckets }) = + [(w, oFPP_ANY, oFPG_ANY, b) | (w,b) <- weightedBuckets ] +genericBuckets (Indirect { bucket }) = [(0, oFPP_ANY, oFPG_ANY, bucket)] +genericBuckets (FastFailover { failoverBuckets }) + = [(0, watchPort, watchGroup, bucketActions) + | FailoverBucket {..} <- failoverBuckets ] + + +gROUP_TYPE_ALL,gROUP_TYPE_SELECT,gROUP_TYPE_INDIRECT,gROUP_TYPE_FF :: Word8 +gROUP_TYPE_ALL = 0 +gROUP_TYPE_SELECT = 1 +gROUP_TYPE_INDIRECT = 2 +gROUP_TYPE_FF = 3 + +groupTypeCode :: Group -> Word8 +groupTypeCode (All {}) = gROUP_TYPE_ALL +groupTypeCode (Select {}) = gROUP_TYPE_SELECT +groupTypeCode (Indirect {}) = gROUP_TYPE_INDIRECT +groupTypeCode (FastFailover {}) = gROUP_TYPE_FF + +bucketsToGroup :: Word8 -> [GenericBucket] -> Group +bucketsToGroup t bkts = case t of + _ | t == gROUP_TYPE_ALL -> All [ al | (_,_,_,al) <- bkts ] + _ | t == gROUP_TYPE_SELECT -> Select [ (w,al) | (w,_,_,al) <- bkts ] + _ | t == gROUP_TYPE_INDIRECT -> case bkts of + [(_,_,_,al)] -> Indirect al + _ -> error ("bucketsToGroup: Bad indirect group with buckets " ++ show bkts) + _ | t == gROUP_TYPE_FF -> + FastFailover [ FailoverBucket { bucketActions = bucketActions + , watchPort = watchPort + , watchGroup = watchGroup + } + | (_,watchPort, watchGroup, bucketActions) <- bkts ] + _ -> error ("bucketsToGroup: unknown group type code: " ++ show t) + +-- TODO: Add SetField, PushPBB, PopPBB, Experimenter actions. +data Action = Output { outputPortID :: PortID + , maxLengthToController :: Maybe Word16 + } + | CopyTTLOut + | CopyTTLIn + | SetMPLSTTL Word8 + | DecMPLSTTL + | PushVLAN Word16 + | PopVLAN + | PushMPLS Word16 + | PopMPLS Word16 + | SetQueue QueueID + | SetGroup GroupID + | SetNetworkTTL Word8 + | DecNetworkTTL + | SetNiciraRegister Int Word32 + | SetField OXM + deriving (Eq,Ord,Show) + +type QueueID = Word32 +type GroupID = Word32 + +data MultipartMessage = PortDesc [Port] + | SwitchDesc { mfrDesc :: String + , hw_desc :: String + , sw_desc :: String + , serial_num :: String + , dp_desc :: String + } + | AllTableStats [TableStats] + | AllPortStats [PortStats] + | GroupDesc [(GroupID, Group)] + deriving (Eq, Show) + + +data PortStats = PortStats { statsPortID :: PortID + , rxPackets :: Int + , txPackets :: Int + , rxBytes :: Int + , txBytes :: Int + , rxDropped :: Int + , txDropped :: Int + , rxErrors :: Int + , txErrors :: Int + , rxFrameErrors :: Int + , rxOverErrors :: Int + , rxCRCErrors :: Int + , collisions :: Int + , portDurationSec :: Int + , portDurationNanoSec :: Int + } deriving (Eq,Ord,Show) + +data TableStats = TableStats { statsTableID :: Word8 + , activeCount :: Int + , lookupCount :: Int + , matchedCount :: Int + } + deriving (Eq,Ord,Show) + +type Header = (Word8, Word8, Len, XID) +type XID = Word32 +type Len = Word16 +type SwitchID = Word64 +type Cookie = Word64 +type PortID = Word32 + + +data PortStateChangeReason = PortAdd + | PortDelete + | PortModify + deriving (Show,Eq,Ord,Enum) + +data Port = Port { portNumber :: PortID + , hwAddress :: EthernetAddress + , portName :: String + , portConfig :: Set PortConfigFlag + , portState :: Set PortStateFlag + , currentFeatures :: Set PortFeature + , advertisedFeatures :: Set PortFeature + , supportedFeatures :: Set PortFeature + , peerFeatures :: Set PortFeature + , currentSpeed :: KiloBitsPerSecond + , maxSpeed :: KiloBitsPerSecond + } deriving (Show,Eq,Ord) + +isPortDown :: Port -> Bool +isPortDown = Set.member PortDown . portConfig + +isPortUp :: Port -> Bool +isPortUp = not . isPortDown + +type KiloBitsPerSecond = Int + +data PortFeature = HD10Mb + | FD10Mb + | HD100Mb + | FD100Mb + | HD1Gb + | FD1Gb + | FD10Gb + | FD40Gb + | FD100Gb + | FD1Tb + | OtherRate + | Copper + | Fiber + | AutoNeg + | Pause + | PauseAsym + deriving (Eq,Ord,Enum,Show) + +data PortConfigFlag = PortDown + | NoRecv + | NoFwd + | NoPacketIn + deriving (Eq,Ord,Enum,Show) + +data PortStateFlag = LinkDown + | Blocked + | Live + deriving (Eq,Ord,Enum,Show) + +data FlowRemovedReason = IdleTimeout + | HardTimeout + | FlowDelete + | GroupDelete + deriving (Eq,Ord,Enum,Show) + +data Match = MatchOXM { oxms :: [OXM] } + deriving (Eq,Ord,Show) + +data OXM = OXMOther { oxmClass :: Word16 + , oxmField :: Word8 + , oxmHasMask :: Bool + , oxmBody :: B.ByteString + } + | InPort { inPortID :: PortID } + | InPhyPort { inPortID :: PortID } + | Metadata { oxmMetadata, oxmMetadataMask :: Word64 + , oxmHasMask :: Bool } + | EthDst { oxmEthDst, oxmEthDstMask :: EthernetAddress + , oxmHasMask :: Bool } + | EthSrc { oxmEthSrc, oxmEthSrcMask :: EthernetAddress + , oxmHasMask :: Bool } + | EthType { oxmEthType :: EthernetTypeCode } + | IPv4Dst { oxmIPDst :: IPAddressPrefix } + | IPv4Src { oxmIPSrc :: IPAddressPrefix } + | NiciraRegister { oxmRegisterIndex :: Int, oxmRegisterValue :: Word32 } + | OXM { oxmOFField :: OXMOFField + , oxmHasMask :: Bool + } + deriving (Eq,Ord,Show) + +oxmHasMask' :: OXM -> Bool +oxmHasMask' (InPort {}) = False +oxmHasMask' (InPhyPort {}) = False +oxmHasMask' (Metadata {oxmHasMask}) = oxmHasMask +oxmHasMask' (EthDst {oxmHasMask}) = oxmHasMask +oxmHasMask' (EthSrc {oxmHasMask}) = oxmHasMask +oxmHasMask' (EthType {}) = False +oxmHasMask' (IPv4Dst {oxmIPDst}) = not $ prefixIsExact oxmIPDst +oxmHasMask' (IPv4Src {oxmIPSrc}) = not $ prefixIsExact oxmIPSrc +oxmHasMask' (NiciraRegister {}) = False +oxmHasMask' (OXM {oxmHasMask}) = oxmHasMask +oxmHasMask' (OXMOther {oxmHasMask}) = oxmHasMask + +data OXMOFField = VLANID VLANMatch + | VLANPCP Word8 + | IPDSCP Word8 + | IPECN Word8 + | IPProto Word8 + | TCPSrc TCPPort + | TCPDst TCPPort + | UDPSrc UDPPort + | UDPDst UDPPort + | SCTPSrc STCPPort + | SCTPDst STCPPort + | ICMPv4_Type Word8 + | ICMPv4_Code Word8 + | ARP_OP Word16 + | ARP_SPA IPAddress IPAddress + | ARP_TPA IPAddress IPAddress + | ARP_SHA EthernetAddress EthernetAddress + | ARP_THA EthernetAddress EthernetAddress + | IPv6Src IPv6Address IPv6Address + | IPv6Dst IPv6Address IPv6Address + | IPv6_FLabel IPv6FlowLabel + | ICMPv6_Type Word8 + | ICMPv6_Code Word8 + | IPv6_ND_Target IPv6Address + | IPv6_ND_SLL EthernetAddress + | IPv6_ND_TLL EthernetAddress + | MPLS_Label MPLSLabel + | MPLS_TC Word8 + | MPLS_BOS Word8 + | PBB_ISID Word32 Word32 + | TunnelID Word64 Word64 + | IPv6_EXTHDR Word16 + deriving (Eq,Ord,Show) + +type TCPPort = Word16 +type UDPPort = Word16 +type STCPPort = Word16 +type IPv6Address = B.ByteString +type IPv6FlowLabel = Word32 +type MPLSLabel = Word32 + +data VLANMatch = Absent + | Present (Maybe Word16) + deriving (Eq,Ord,Show) + +data PacketInReason = NoMatch + | MatchedAction + | InvalidTTL + deriving (Eq,Ord,Enum,Show) + +packetInReasonCodeMap :: Bimap PacketInReason Word8 +packetInReasonCodeMap = + Bimap.fromList [ (NoMatch, 0) + , (MatchedAction, 1) + , (InvalidTTL, 2) + ] + +data ErrorType = HelloFailed + | BadRequest BadRequestError + | BadAction + | BadInstruction BadInstructionError + | BadMatch BadMatchError + | FlowModFailed + | GroupModFailed BadGroupModError + | PortModFailed + | TableModFailed + | QueueOpFailed + | SwitchConfigFailed + | RoleRequestFailed + | MeterModFailed + | TableFeaturesFailed + | ExperimenterError + deriving (Eq,Ord,Show) + +data BadRequestError = BadVersion + | BadType + | BadMultipart + | BadExperimenter + | BadExpType + | BadPermission + | BadLen + | BufferEmpty + | BufferUnknown + | BadTableID + | IsSlave + | BadPort + | BadPacket + | MultipartBufferOverflow + deriving (Eq,Ord,Enum,Show) + +badRequestCodeMap :: Bimap BadRequestError Word16 +badRequestCodeMap = + Bimap.fromList [ (BadVersion ,0) + , (BadType,1) + , (BadMultipart,2) + , (BadExperimenter,3) + , (BadExpType,4) + , (BadPermission,5) + , (BadLen,6) + , (BufferEmpty,7) + , (BufferUnknown,8) + , (BadTableID,9) + , (IsSlave,10) + , (BadPort,11) + , (BadPacket,12) + , (MultipartBufferOverflow,13) + ] + +data BadMatchError = BadMatchType + | BadMatchLength + | BadMatchTag + | BadMatchDLAddrMask + | BadMatchNWAddrMask + | BadWildcards + | BadMatchField + | BadMatchValue + | BadMatchMask + | BadMatchPrereq + | BadMatchDupField + | BadMatchPermissions + deriving (Eq,Ord,Enum,Show) + +badMatchCodeMap :: Bimap BadMatchError Word16 +badMatchCodeMap = + Bimap.fromList [ (BadMatchType, 0) + , (BadMatchLength, 1) + , (BadMatchTag, 2) + , (BadMatchDLAddrMask, 3) + , (BadMatchNWAddrMask, 4) + , (BadWildcards, 5) + , (BadMatchField, 6) + , (BadMatchValue, 7) + , (BadMatchMask, 8) + , (BadMatchPrereq, 9) + , (BadMatchDupField, 10) + , (BadMatchPermissions,11) + ] + +data BadInstructionError = UnknownInstruction + | UnsupportedInstruction + | BadInstructionTableID + | UnsupportedMetadata + | UnsupportedMetadataMask + | BadExperimenterID + | BadExperimenterType + | BadInstructionLength + | BadInstructionPermission + deriving (Eq,Ord,Enum,Show) + +badInstructionCodeMap :: Bimap BadInstructionError Word16 +badInstructionCodeMap = + Bimap.fromList [ (UnknownInstruction, 0) + , (UnsupportedInstruction, 1) + , (BadInstructionTableID, 2) + , (UnsupportedMetadata, 3) + , (UnsupportedMetadataMask, 4) + , (BadExperimenterID, 5) + , (BadExperimenterType, 6) + , (BadInstructionLength, 7) + , (BadInstructionPermission, 8) + ] + +data BadGroupModError = GroupExistsError + | GroupInvalidError + | GroupUnsupportedWeight + | GroupTableFullError + | GroupBucketsFullError + | GroupChainsUnsupported + | GroupWatchUnsupported + | GroupWouldCauseLoop + | GroupDoesNotExist + | GroupReferencedByOtherGroup + | GroupBadType + | GroupBadCommand + | GroupBadBucket + | GroupBadWatch + | GroupPermissionError + deriving (Eq,Ord,Enum,Show) + +badGroupModCodeMap :: Bimap BadGroupModError Word16 +badGroupModCodeMap = + Bimap.fromList [ (GroupExistsError, 0) + , (GroupInvalidError, 1) + , (GroupUnsupportedWeight, 2) + , (GroupTableFullError, 3) + , (GroupBucketsFullError, 4) + , (GroupChainsUnsupported, 5) + , (GroupWatchUnsupported, 6) + , (GroupWouldCauseLoop, 7) + , (GroupDoesNotExist, 8) + , (GroupReferencedByOtherGroup, 9) + , (GroupBadType, 10) + , (GroupBadCommand, 11) + , (GroupBadBucket, 12) + , (GroupBadWatch, 13) + , (GroupPermissionError, 14) + ] + +data ConfigFlag = FragNormal + | FragDrop + | FragReasm + -- What is this? | FragMask + deriving (Eq,Ord,Enum,Show) + +data SwitchCapability = FlowStats + | HasTableStats + | HasPortStats + | GroupStats + | IPReassembly + | QueueStats + | PortBlocked + deriving (Eq,Ord,Enum,Show) + + +configFlagsFields :: [(Int, ConfigFlag)] +configFlagsFields = [ (0,FragNormal) + , (1,FragDrop) + , (2,FragReasm) + ] + +switchCapabilityFields :: [(Int, SwitchCapability)] +switchCapabilityFields = [ (0, FlowStats) + , (1, HasTableStats) + , (2, HasPortStats) + , (3, GroupStats) + , (5, IPReassembly) + , (6, QueueStats) + , (8, PortBlocked) + ] + +instance Binary Message where + get = do hdr <- getHeader + getBody hdr + + put (Hello { xid }) = + putHeader hello_type_code len_header xid + put (Error {xid, body}) = do + putHeader error_type_code (numMessageBytes $ B.length body) xid + () <- error "BROKEN" + putByteString body + put (EchoRequest {xid, body}) = do + putHeader echo_request_type_code (numMessageBytes $ B.length body) xid + putByteString body + put (EchoReply {xid, body}) = do + putHeader echo_reply_type_code (numMessageBytes $ B.length body) xid + putByteString body + put (FeatureRequest {xid}) = + putHeader feature_request_type_code len_header xid + put (FeatureReply {..}) = do + putHeader feature_reply_type_code (len_header + 24) xid + putWord64be sid + putWord32be numBuffers + putWord8 numTables + putWord8 auxID + putWord16be 0 + putWord32be $ setToBitSet switchCapabilityFields capabilities + putWord32be 0 + put (ConfigRequest {xid}) = + putHeader config_request_type_code len_header xid + put (ConfigReply {..}) = do + putHeader config_reply_type_code (len_header + 4) xid + putWord16be $ setToBitSet configFlagsFields configFlags + putWord16be missSendLen + put (ConfigSet {..}) = do + putHeader config_set_type_code (len_header + 4) xid + putWord16be $ setToBitSet configFlagsFields configFlags + putWord16be missSendLen + put (RequestTableFeatures {..}) = do + putHeader multipart_request_type_code (len_header + 8) xid + putWord16be oFPMP_TABLE_FEATURES + putWord16be 0 + putWord32be 0 + mapM_ putTableFeature tableFeatures + put (RequestPorts {..}) = do + putHeader multipart_request_type_code (len_header + 8) xid + putWord16be multipart_type_port_desc + putWord16be 0 + putWord32be 0 + put (RequestGroups {..}) = do + putHeader multipart_request_type_code (len_header + 8) xid + putWord16be multipart_type_group_desc + putWord16be 0 + putWord32be 0 + put (RequestSwitchDesc {..}) = do + putHeader multipart_request_type_code (len_header + 8) xid + putWord16be multipart_type_desc + putWord16be 0 + putWord32be 0 + put (RequestTableStats {..}) = do + putHeader multipart_request_type_code (len_header + 8) xid + putWord16be multipart_table_stats + putWord16be 0 + putWord32be 0 + put (RequestPortStats {..}) = do + putHeader multipart_request_type_code (len_header + 8 + 8) xid + putWord16be multipart_port_stats + putWord16be 0 + putWord32be 0 + putWord32be portID + putWord32be 0 + put (PacketOut {..}) = do + let actionsLength = actionListLength actions + let len' = 24 + actionsLength + B.length payload + putHeader packet_out_type_code (fromIntegral len') xid + putWord32be $ maybe (-1) id packetOutBufferID + putWord32be $ maybe controllerPortID id inPort + putWord16be $ fromIntegral actionsLength + putWord32be 0 + putWord16be 0 + mapM_ putAction actions + putByteString payload + put (BarrierRequest {..}) = do + putHeader barrier_request_type_code len_header xid + put (AddFlow {..}) = do + let len = len_header + 40 + + fromIntegral (matchLength match) + + fromIntegral (sum $ map instructionLength instructions) + putHeader flow_mod_type_code len xid + putWord64be cookie + putWord64be 0 + putWord8 tableID + putWord8 fmod_add + putWord16be idleTimeout + putWord16be hardTimeout + putWord16be priority + putWord32be $ maybe (-1) id bufferID + putWord64be 0 -- unused port ID and group ID + let flags = + (cond sendFlowRemoved (flip setBit 0)) . + (cond checkOverlap (flip setBit 1)) . + (cond (not countPackets) (flip setBit 3)) . + (cond (not countBytes) (flip setBit 4)) $ + 0 + putWord16be flags + putWord16be 0 --padding + putMatch match + mapM_ putInstruction instructions + + put (DeleteFlowStrict {..}) = do + let len = len_header + 40 + fromIntegral (matchLength match) + putHeader flow_mod_type_code len xid + putWord64be cookie + putWord64be (-1) + putWord8 tableID + putWord8 fmod_delete_strict + putWord32be 0 -- unused idle and hard timeout + putWord16be priority + putWord32be 0 + putWord32be $ maybe (-1) id outPort + putWord32be $ maybe (-1) id outGroup + putWord32be 0 -- unused flags and padding + putMatch match + + put (DeleteFlow {..}) = do + let len = len_header + 40 + fromIntegral (matchLength match) + putHeader flow_mod_type_code len xid + putWord64be cookie + putWord64be cookieMask + putWord8 $ maybe (-1) id maybeTableID + putWord8 fmod_delete + putWord32be 0 -- unused idle and hard timeout + putWord16be priority + putWord32be 0 + putWord32be $ maybe (-1) id outPort + putWord32be $ maybe (-1) id outGroup + putWord32be 0 -- unused flags and padding + putMatch match + + put (ModifyFlowStrict {..}) = do + let len = len_header + 40 + + fromIntegral (matchLength match) + + fromIntegral (sum $ map instructionLength instructions) + putHeader flow_mod_type_code len xid + putWord64be cookie + putWord64be (-1) + putWord8 tableID + putWord8 fmod_modify_strict + putWord32be 0 -- unused idle & hard timeouts + putWord16be priority + putWord32be (-1) --bufferID + putWord64be 0 -- unused port ID and group ID + let flags = if resetCounters then setBit 2 0 else 0 + putWord16be flags + putWord16be 0 --padding + putMatch match + mapM_ putInstruction instructions + + put (ModifyFlow {..}) = do + let len = len_header + 40 + + fromIntegral (matchLength match) + + fromIntegral (sum $ map instructionLength instructions) + putHeader flow_mod_type_code len xid + putWord64be cookie + putWord64be cookieMask + putWord8 tableID + putWord8 fmod_modify + putWord32be 0 -- unused idle & hard timeouts + putWord16be 0 + putWord32be (-1) --bufferID + putWord64be 0 -- unused port ID and group ID + let flags = if resetCounters then setBit 2 0 else 0 + putWord16be flags + putWord16be 0 --padding + putMatch match + mapM_ putInstruction instructions + + put (AddGroup {..}) = do + let bkts = genericBuckets group + let len = groupModLength bkts + putHeader group_mod_type_code len xid + putWord16be oFPGC_ADD + putWord8 $ groupTypeCode group + putWord8 0 --padding + putWord32be groupID + putBuckets bkts + put (ModifyGroup {..}) = do + let bkts = genericBuckets group + let len = groupModLength bkts + putHeader group_mod_type_code len xid + putWord16be oFPGC_MODIFY + putWord8 $ groupTypeCode group + putWord8 0 --padding + putWord32be groupID + putBuckets bkts + put (DeleteGroup {..}) = do + putHeader group_mod_type_code (len_header + 8) xid + putWord16be oFPGC_DELETE + putWord8 0 + putWord8 0 + putWord32be groupID + put (PortMod {..}) = do + putHeader port_mod_type_code (len_header + 32) xid + putWord32be portID + putWord32be 0 --pad + putEthernetAddress hwAddr + putWord16be 0 --pad + let (trueConfigSet,allConfigSet) = mapToBitSets portConfigCodeMap portModConfig + putWord32be trueConfigSet + putWord32be allConfigSet + putWord32be $ setToBitSet portFeaturesCodeMap portModAdvertised + putWord32be 0 --pad + +putTableFeature :: TableFeature -> Put +putTableFeature (TableFeature {..}) = do + putWord16be 64 + putWord8 tableFeatureTableID + putWord8 0 -- pad + putWord32be 0 -- pad + putByteString $ trimTableName tableName + putWord64be metadataMatch + putWord64be metadataWrite + putWord32be 0 + putWord32be $ fromIntegral maxEntries + +trimTableName :: String -> B.ByteString +trimTableName name = + B.take oFP_MAX_TABLE_NAME_LEN $ + BC.pack $ + name ++ replicate (oFP_MAX_TABLE_NAME_LEN - length name) ' ' + +oFP_MAX_TABLE_NAME_LEN :: Int +oFP_MAX_TABLE_NAME_LEN = 32 + +groupModLength :: [GenericBucket] -> Word16 +groupModLength bkts = len_header + 8 + fromIntegral (sum (map bucketSize bkts)) + +putBuckets :: [GenericBucket] -> Put +putBuckets = mapM_ putBucket + +actionListLength :: ActionList -> Int +actionListLength = sum . map actionLength + +bucketSize :: GenericBucket -> Int +bucketSize (_,_,_,actions) = 16 + actionListLength actions + +putBucket :: GenericBucket -> Put +putBucket b@(w,wp,wg,al) = do + putWord16be $ fromIntegral $ bucketSize b + putWord16be w + putWord32be wp + putWord32be wg + putWord32be 0 -- padding + putActionList al + +cond :: Bool -> (a -> a) -> a -> a +cond True f a = f a +cond False _ a = a + +fmod_add, fmod_modify, fmod_modify_strict, fmod_delete, fmod_delete_strict :: Word8 +fmod_add = 0 +fmod_modify = 1 +fmod_modify_strict = 2 +fmod_delete = 3 +fmod_delete_strict = 4 + +instructionLength :: Instruction -> Int +instructionLength ClearActions = 8 +instructionLength (WriteActions actions) + = 8 + actionListLength actions +instructionLength (ApplyActions actions) + = 8 + actionListLength actions +instructionLength (GotoTable _) = 8 +instructionLength (WriteMetadata {}) = 24 +instructionLength (Meter _) = 8 + +putActionList :: ActionList -> Put +putActionList = mapM_ putAction + +putInstruction :: Instruction -> Put +putInstruction i@(GotoTable t) = do + putWord16be 1 + putWord16be $ fromIntegral $ instructionLength i + putWord8 t + putByteString $ B.replicate 3 0 +putInstruction i@(WriteMetadata {..}) = do + putWord16be 2 + putWord16be $ fromIntegral $ instructionLength i + putWord32be 0 + putWord64be metadata + putWord64be metadataMask +putInstruction i@(WriteActions actions) = do + putWord16be 3 + putWord16be $ fromIntegral $ instructionLength i + putWord32be 0 + putActionList actions +putInstruction i@(ApplyActions actions) = do + putWord16be 4 + putWord16be $ fromIntegral $ instructionLength i + putWord32be 0 + putActionList actions +putInstruction ClearActions = do + putWord16be 5 + putWord16be $ fromIntegral $ instructionLength ClearActions + putWord32be 0 +putInstruction i@(Meter mid) = do + putWord16be 6 + putWord16be $ fromIntegral $ instructionLength i + putWord32be mid + +putAction :: Action -> Put +putAction (SetField oxm) = do + putWord16be oFPAT_SET_FIELD + let len1 = 4 + oxmLen oxm + remainder = (- len1 :: Int) `mod` 8 + len = len1 + remainder + putWord16be $ fromIntegral len + putOXM oxm + putByteString $ B.replicate remainder 0 + +putAction (Output {..}) = do + putWord16be output_action_type_code + putWord16be 16 + putWord32be outputPortID + putWord16be $ maybe (-1) (\x -> assert (x <= 0xffe5) x) maxLengthToController + putWord32be 0 + putWord16be 0 +putAction CopyTTLOut = do + putWord16be 11 + putWord16be 8 + putWord32be 0 +putAction CopyTTLIn = do + putWord16be 12 + putWord16be 8 + putWord32be 0 +putAction (SetMPLSTTL ttl) = do + putWord16be 15 + putWord16be 8 + putWord8 ttl + putWord8 0 + putWord16be 0 +putAction DecMPLSTTL = do + putWord16be 16 + putWord16be 8 + putWord32be 0 +putAction (PushVLAN w) = do + putWord16be 17 + putWord16be 8 + putWord16be w + putWord16be 0 +putAction PopVLAN = do + putWord16be 18 + putWord16be 8 + putWord32be 0 +putAction (PushMPLS w) = do + putWord16be 19 + putWord16be 8 + putWord16be w + putWord16be 0 +putAction (PopMPLS w) = do + putWord16be 20 + putWord16be 8 + putWord16be w + putWord16be 0 +putAction (SetQueue w) = do + putWord16be 21 + putWord16be 8 + putWord32be w +putAction (SetGroup w) = do + putWord16be 22 + putWord16be 8 + putWord32be w +putAction (SetNetworkTTL w) = do + putWord16be 23 + putWord16be 8 + putWord8 w + putWord8 0 + putWord16be 0 +putAction DecNetworkTTL = do + putWord16be 24 + putWord16be 8 + putWord32be 0 +putAction (SetNiciraRegister idx v) = do + putWord16be oFPAT_EXPERIMENTER + putWord16be 24 + putWord32be nX_VENDOR_ID + putWord16be nXAST_REG_LOAD + let n_bits = 32 + offset = 0 + putWord16be $ shiftL offset 6 .|. (n_bits - 1) + putWord32be $ nXM_HEADER 1 (fromIntegral idx) 4 + putWord64be $ fromIntegral v + +nXM_HEADER__ :: Word32 -> Word32 -> Bool -> Word32 -> Word32 +nXM_HEADER__ vendor field hasMask len + = shiftL vendor 16 .|. shiftL field 9 .|. shiftL hasMask' 8 .|. len + where hasMask' | hasMask = 1 + | otherwise = 0 + +nXM_HEADER :: Word32 -> Word32 -> Word32 -> Word32 +nXM_HEADER vendor field len = nXM_HEADER__ vendor field False len + +nXAST_REG_LOAD :: Word16 +nXAST_REG_LOAD = 7 + +nX_VENDOR_ID :: Word32 +nX_VENDOR_ID = 0x00002320 + +oFPAT_EXPERIMENTER :: Word16 +oFPAT_EXPERIMENTER = -1 + +oFPAT_SET_FIELD :: Word16 +oFPAT_SET_FIELD = 25 + +output_action_type_code :: Word16 +output_action_type_code = 0 + +controllerPortID :: PortID +controllerPortID = 0xfffffffd + +actionLength :: Action -> Int +actionLength (SetField oxm) = + let len1 = 4 + oxmLen oxm + remainder = (- len1 :: Int) `mod` 8 + in len1 + remainder + +actionLength (Output {..}) = 16 +actionLength CopyTTLOut = 8 +actionLength CopyTTLIn = 8 +actionLength (SetMPLSTTL _) = 8 +actionLength DecMPLSTTL = 8 +actionLength (PushVLAN _) = 8 +actionLength PopVLAN = 8 +actionLength (PushMPLS _) = 8 +actionLength (PopMPLS _) = 8 +actionLength (SetQueue _) = 8 +actionLength (SetGroup _) = 8 +actionLength (SetNetworkTTL _) = 8 +actionLength DecNetworkTTL = 8 +actionLength (SetNiciraRegister _ _) = 24 + +multipart_type_desc :: Word16 +multipart_type_desc = 0 + +multipart_table_stats :: Word16 +multipart_table_stats = 3 + +multipart_port_stats :: Word16 +multipart_port_stats = 4 + +multipart_type_port_desc :: Word16 +multipart_type_port_desc = 13 + +multipart_type_group_desc :: Word16 +multipart_type_group_desc = 7 + +getHeader :: Get Header +getHeader = + do vid <- getWord8 + typ <- getWord8 + len <- getWord16be + xid <- getWord32be + assert (vid == version_of13) $ return (vid, typ, len, xid) + +putHeader :: Word8 -> Len -> XID -> Put +putHeader typeCode' len xid = do + putWord8 version_of13 + putWord8 typeCode' + putWord16be len + putWord32be xid + +getBody :: Header -> Get Message +getBody hdr@(_, typ, len, xid) + | typ == hello_type_code = + do skip $ numBodyBytes len + return $ Hello { xid = xid, len = len } + + | typ == error_type_code = + do errorType <- getWord16be + errorCode <- getWord16be + let errTyp' = case errorType of + _ | errorType == 0 -> HelloFailed + _ | errorType == 1 -> BadRequest $ fromJust $ Bimap.lookupR errorCode badRequestCodeMap + _ | errorType == 2 -> BadAction + _ | errorType == 3 -> BadInstruction $ fromJust $ Bimap.lookupR errorCode badInstructionCodeMap + _ | errorType == 4 -> BadMatch $ fromJust $ Bimap.lookupR errorCode badMatchCodeMap + _ | errorType == 5 -> FlowModFailed + _ | errorType == 6 -> GroupModFailed $ fromJust $ Bimap.lookupR errorCode badGroupModCodeMap + _ | errorType == 7 -> PortModFailed + _ | errorType == 8 -> TableModFailed + _ | errorType == 9 -> QueueOpFailed + _ | errorType == 10 -> SwitchConfigFailed + _ | errorType == 11 -> RoleRequestFailed + _ | errorType == 12 -> MeterModFailed + _ | errorType == 13 -> TableFeaturesFailed + _ | errorType == 0xffff -> ExperimenterError + _ -> error "bad error type code" + body <- getByteString $ numBodyBytes len - 4 + return $ Error { xid = xid + , errorType = errTyp' + , errorCode = errorCode + , body = body } + + | typ == echo_request_type_code = + do body <- getByteString $ numBodyBytes len + return $ EchoRequest { xid = xid, body = body } + + | typ == echo_reply_type_code = + do body <- getByteString $ numBodyBytes len + return $ EchoReply { xid = xid, body = body } + + | typ == feature_reply_type_code = + do sid <- getWord64be + numBuffers <- getWord32be + numTables <- getWord8 + auxID <- getWord8 + skip 2 + caps <- getWord32be + skip 4 + return $ + FeatureReply { xid = xid + , sid = sid + , numBuffers = numBuffers + , numTables = numTables + , auxID = auxID + , capabilities = bitSetToSet switchCapabilityFields caps + } + + | typ == config_request_type_code = return $ ConfigRequest { xid = xid } + + | typ == config_reply_type_code = + do flags <- getWord16be + missSendLen <- getWord16be + return $ ConfigReply { xid = xid + , configFlags = bitSetToSet configFlagsFields flags + , missSendLen = missSendLen + } + + | typ == config_set_type_code = + do flags <- getWord16be + missSendLen <- getWord16be + return $ ConfigSet { xid = xid + , configFlags = bitSetToSet configFlagsFields flags + , missSendLen = missSendLen + } + + | typ == packet_in_type_code = + do bufferID' <- getWord32be + let bufferID = if bufferID' == -1 + then Nothing + else Just bufferID' + totalLen <- getWord16be + reason <- getWord8 + tableID <- getWord8 + cookie <- getWord64be + match <- getMatch + skip 2 + readSoFar <- bytesRead + rest <- getByteString $ fromIntegral $ fromIntegral len - readSoFar + return $ PacketIn { xid = xid + , bufferID = bufferID + , totalLen = totalLen + , reason = fromJust $ Bimap.lookupR reason packetInReasonCodeMap + , tableID = tableID + , cookie = cookie + , match = match + , payload = rest + } + | typ == flow_removed_type_code = + do cookie <- getWord64be + priority <- getWord16be + reason <- getWord8 + let flowRemovedReason | reason == 0 = IdleTimeout + | reason == 1 = HardTimeout + | reason == 2 = FlowDelete + | reason == 3 = GroupDelete + | otherwise = error "bad flow removed reason code" + table <- getWord8 + duration_sec <- getWord32be + duration_nsec <- getWord32be + idleTimeout <- getWord16be + hardTimeout <- getWord16be + packetCount <- getWord64be + byteCount <- getWord64be + match <- getMatch + return $ FlowRemoved { xid = xid + , cookie = cookie + , priority = priority + , flowRemovedReason = flowRemovedReason + , tableID = table + , duration_sec = duration_sec + , duration_nsec = duration_nsec + , idleTimeout = idleTimeout + , hardTimeout = hardTimeout + , packetCount = packetCount + , byteCount = byteCount + , match = match + } + + | typ == port_status_type_code = + do reason <- toReason <$> getWord8 + skip 7 + port <- getPort + return $ PortStatus { xid = xid + , portStateChangeReason = reason + , port = port + } + | typ == multipart_reply_type_code = + do multipart_type <- getWord16be + moreToFollow <- flip testBit 0 <$> getWord16be + skip 4 + let bodyLen = fromIntegral len - 16 + msg <- case multipart_type of + + _ | multipart_type == multipart_type_port_desc -> + assert (0 == (bodyLen `mod` portDescLen)) $ + PortDesc <$> replicateM (bodyLen `div` portDescLen) getPort + + _ | multipart_type == multipart_type_desc -> + getSwitchDesc + + _ | multipart_type == multipart_table_stats -> + assert (0 == (bodyLen `mod` tableStatsLen)) $ + AllTableStats <$> replicateM (bodyLen `div` tableStatsLen) getTableStats + + _ | multipart_type == multipart_port_stats -> + assert (0 == (bodyLen `mod` portStatsLen)) $ + AllPortStats <$> replicateM (bodyLen `div` portStatsLen) getPortStats + + _ | multipart_type == multipart_type_group_desc -> + GroupDesc <$> getGroupDescs bodyLen + + _ | otherwise -> + error ("Invalid multipart message type " ++ show multipart_type) + + return $ MultipartReply { xid = xid + , moreToCome = moreToFollow + , multipartMessage = msg + } + | typ == barrier_reply_type_code = + do return $ BarrierReply { xid = xid } + | otherwise = + do skip $ numBodyBytes len + return $ Undefined hdr + +getGroupDescs :: Int -> Get [(GroupID, Group)] +getGroupDescs bodyLen + | bodyLen == 0 = return [] + | otherwise = do + (glen, gd) <- getGroupDesc + gds <- getGroupDescs (bodyLen - glen) + return $ gd : gds + +getGroupDesc :: Get (Int, (GroupID, Group)) +getGroupDesc = do + len <- getWord16be + typ <- getWord8 + _ <- getWord8 + gid <- getWord32be + buckets <- getGenericBuckets (fromIntegral len - 8) + return (fromIntegral len, (gid, bucketsToGroup typ buckets)) + +getGenericBuckets :: Int -> Get [GenericBucket] +getGenericBuckets totalLen + | totalLen == 0 = return [] + | otherwise = do + (len, bkt) <- getGenericBucket + bkts <- getGenericBuckets (totalLen - len) + return $ bkt : bkts + +getGenericBucket :: Get (Int, GenericBucket) +getGenericBucket = do + len <- getWord16be + weight <- getWord16be + wp <- getWord32be + wg <- getWord32be + _ <- getWord32be --padding + al <- getActionList (fromIntegral len - 16) + return (fromIntegral len, (weight,wp,wg,al)) + +getActionList :: Int -> Get [Action] +getActionList totalLen + | totalLen == 0 = return [] + | otherwise = do + (len, act) <- getAction + acts <- getActionList (totalLen - len) + return $ act : acts + +getAction :: Get (Int, Action) +getAction = do + typ <- getWord16be + len <- getWord16be + act <- case typ of + _ | typ == output_action_type_code -> getOutputAction + _ -> error ("unhandled action typ: " ++ show typ) + return (fromIntegral len, act) + +getOutputAction :: Get Action +getOutputAction = do + pid <- getWord32be + max_len <- getWord16be + skip 6 + return $ Output pid (if max_len == -1 then Nothing else Just max_len) + +portDescLen :: Int +portDescLen = 64 + +tableStatsLen :: Int +tableStatsLen = 24 + +portStatsLen :: Int +portStatsLen = 112 + +getPortStats :: Get PortStats +getPortStats = do + portID <- getWord32be + skip 4 + rxPackets <- fromIntegral <$> getWord64be + txPackets <- fromIntegral <$> getWord64be + rxBytes <- fromIntegral <$> getWord64be + txBytes <- fromIntegral <$> getWord64be + rxDropped <- fromIntegral <$> getWord64be + txDropped <- fromIntegral <$> getWord64be + rxErrors <- fromIntegral <$> getWord64be + txErrors <- fromIntegral <$> getWord64be + rxFrameErrors <- fromIntegral <$> getWord64be + rxOverErrors <- fromIntegral <$> getWord64be + rxCRCErrors <- fromIntegral <$> getWord64be + collisions <- fromIntegral <$> getWord64be + portDurationSec <- fromIntegral <$> getWord32be + portDurationNanoSec <- fromIntegral <$> getWord32be + return $ PortStats { statsPortID = portID + , rxPackets = rxPackets + , txPackets = txPackets + , rxBytes = rxBytes + , txBytes = txBytes + , rxDropped = rxDropped + , txDropped = txDropped + , rxErrors = rxErrors + , txErrors = txErrors + , rxFrameErrors = rxFrameErrors + , rxOverErrors = rxOverErrors + , rxCRCErrors = rxCRCErrors + , collisions = collisions + , portDurationSec = portDurationSec + , portDurationNanoSec = portDurationNanoSec + } + + +getTableStats :: Get TableStats +getTableStats = do + tableID <- getWord8 + skip 3 + activeCount <- fromIntegral <$> getWord32be + lookupCount <- fromIntegral <$> getWord64be + matchedCount <- fromIntegral <$> getWord64be + return $ TableStats { statsTableID = tableID + , activeCount = activeCount + , lookupCount = lookupCount + , matchedCount = matchedCount + } + +getSwitchDesc :: Get MultipartMessage +getSwitchDesc = do + mfrDesc <- BC.unpack . BC.takeWhile (/= '\NUL') <$> getByteString desc_str_len + hw_desc <- BC.unpack . BC.takeWhile (/= '\NUL') <$> getByteString desc_str_len + sw_desc <- BC.unpack . BC.takeWhile (/= '\NUL') <$> getByteString desc_str_len + serial_num <- BC.unpack . BC.takeWhile (/= '\NUL') <$> getByteString serial_num_len + dp_desc <- BC.unpack . BC.takeWhile (/= '\NUL') <$> getByteString desc_str_len + return $ SwitchDesc { mfrDesc = mfrDesc + , hw_desc = hw_desc + , sw_desc = sw_desc + , serial_num = serial_num + , dp_desc = dp_desc + } + where + desc_str_len = 256 + serial_num_len = 32 + +getPort :: Get Port +getPort = do + portNumber <- getWord32be + skip 4 + hwAddress <- getEthernetAddress + skip 2 + portName <- BC.unpack . BC.takeWhile (/= '\NUL') <$> getByteString 16 + portConfig <- toPortConfig <$> getWord32be + portState <- toPortStates <$> getWord32be + currentFeatures <- toPortFeatures <$> getWord32be + advertisedFeatures <- toPortFeatures <$> getWord32be + supportedFeatures <- toPortFeatures <$> getWord32be + peerFeatures <- toPortFeatures <$> getWord32be + currentSpeed <- getWord32be + maxSpeed <- getWord32be + return $ Port { portNumber = portNumber + , hwAddress = hwAddress + , portName = portName + , portConfig = portConfig + , portState = portState + , currentFeatures = currentFeatures + , advertisedFeatures = advertisedFeatures + , supportedFeatures = supportedFeatures + , peerFeatures = peerFeatures + , currentSpeed = fromIntegral currentSpeed + , maxSpeed = fromIntegral maxSpeed + } + +toPortConfig :: Word32 -> Set PortConfigFlag +toPortConfig = bitSetToSet portConfigCodeMap + +portConfigCodeMap :: [(Int, PortConfigFlag)] +portConfigCodeMap = [ (0, PortDown) + , (2, NoRecv) + , (5, NoFwd) + , (6, NoPacketIn) + ] + +toPortStates :: Word32 -> Set PortStateFlag +toPortStates = bitSetToSet portStateCodeMap + +portStateCodeMap :: [(Int, PortStateFlag)] +portStateCodeMap = [ (0, LinkDown) + , (1, Blocked) + , (2, Live) + ] + +toPortFeatures :: Word32 -> Set PortFeature +toPortFeatures = bitSetToSet portFeaturesCodeMap + +portFeaturesCodeMap :: [(Int, PortFeature)] +portFeaturesCodeMap = + [ (0, HD10Mb) + , (1, FD10Mb) + , (2, HD100Mb) + , (3, FD100Mb) + , (4, HD1Gb) + , (5, FD1Gb) + , (6, FD10Gb) + , (7, FD40Gb) + , (8, FD100Gb) + , (9, FD1Tb) + , (10, OtherRate) + , (11, Copper) + , (12, Fiber) + , (13, AutoNeg) + , (14, Pause) + , (15, PauseAsym) + ] + +toReason :: Word8 -> PortStateChangeReason +toReason 0 = PortAdd +toReason 1 = PortDelete +toReason 2 = PortModify +toReason code = error ("Invalid port state reason code: " ++ show code) + +matchLength :: Match -> Int +matchLength (MatchOXM oxms) = 4 + oxmsLen + padding + where + oxmsLen = sum $ map oxmLen oxms + padding = (-(4 + oxmsLen)) `mod` 8 + +putMatch :: Match -> Put +putMatch (MatchOXM oxms) = do + putWord16be 1 + let oxmsLen = sum $ map oxmLen oxms + let len = 4 + oxmsLen + putWord16be $ fromIntegral len + mapM_ putOXM oxms + let remainder = (- (len :: Int)) `mod` 8 + putByteString $ B.replicate remainder 0 + +putOXM :: OXM -> Put +putOXM (OXMOther {..}) = error "Non-basic OXMs are not supported." + +putOXM (NiciraRegister r v) = do + putWord16be 1 + putWord8 $ fromIntegral r `shiftL` 1 + putWord8 4 + putWord32be v + +putOXM oxmof = do + putOXMClass + putOXMField (fieldCode oxmof) (oxmHasMask' oxmof) + putWord8 $ fromIntegral (oxmLen oxmof - tlv_header_len) + case oxmof of + InPort p -> putWord32be p + InPhyPort p -> putWord32be p + Metadata w w' hasMask -> do putWord64be w + when hasMask $ putWord64be w' + EthDst a mask hasMask -> do + putEthernetAddress a + when hasMask $ putEthernetAddress mask + EthSrc a mask hasMask -> do + putEthernetAddress a + when hasMask $ putEthernetAddress mask + EthType a -> putWord16be a + + IPv4Dst a -> do putIPAddress $ addressPart a + unless (prefixIsExact a) $ putIPAddress $ prefixToMask a + IPv4Src a -> do putIPAddress $ addressPart a + unless (prefixIsExact a) $ putIPAddress $ prefixToMask a + OXM oxm _ -> case oxm of + VLANID Absent -> putWord16be 0 + VLANID (Present Nothing) -> do putWord16be vlan_present_mask + putWord16be vlan_present_mask + VLANID (Present (Just vid)) -> putWord16be vid + VLANPCP a -> putWord8 a + IPDSCP a -> putWord8 a + IPECN a -> putWord8 a + IPProto a -> putWord8 a + ARP_OP op -> putWord16be op + ARP_TPA a _ -> putIPAddress a + + + +putIPAddress :: IPAddress -> Put +putIPAddress (IPAddress a) = putWord32be a + +getIPAddress :: Get IPAddress +getIPAddress = IPAddress <$> getWord32be + +vlan_present_mask :: Word16 +vlan_present_mask = 0x1000 + +fieldCode :: OXM -> Int +fieldCode (InPort {}) = 0 +fieldCode (InPhyPort {}) = 1 +fieldCode (Metadata {}) = 2 +fieldCode (EthDst {}) = 3 +fieldCode (EthSrc {}) = 4 +fieldCode (EthType {}) = 5 +fieldCode (OXM { oxmOFField = VLANID _}) = 6 +fieldCode (OXM { oxmOFField = VLANPCP _}) = 7 +fieldCode (OXM { oxmOFField = IPDSCP _}) = 8 +fieldCode (OXM { oxmOFField = ARP_OP _}) = 21 +fieldCode (OXM { oxmOFField = ARP_TPA _ _}) = 23 +fieldCode (IPv4Src {}) = 11 +fieldCode (IPv4Dst {}) = 12 +fieldCode oxm = error $ "fieldCode: not yet implemented for " ++ show oxm + +putOXMClass :: Put +putOXMClass = putWord16be 0x8000 + +putOXMField :: Int -> Bool -> Put +putOXMField x hasMask + = putWord8 $ fromIntegral x `shiftL` 1 + if hasMask then 1 else 0 + +oxmLen :: OXM -> Int +oxmLen oxm = + tlv_header_len + + case oxm of + OXMOther {} -> error "Non-basic OXM match classes are not supported." + InPort _ -> 4 + InPhyPort _ -> 4 + Metadata _ _ False -> 8 + EthDst _ _ False -> 6 + EthDst _ _ True -> 6 * 2 + EthSrc _ _ False -> 6 + EthSrc _ _ True -> 6 * 2 + EthType _ -> 2 + NiciraRegister _ _ -> 4 + IPv4Dst a | prefixIsExact a -> 4 + | otherwise -> 4 * 2 + IPv4Src a | prefixIsExact a -> 4 + | otherwise -> 4 * 2 + + OXM (VLANID _) False -> 2 + OXM (VLANPCP _) False -> 1 + OXM (IPDSCP _) False -> 1 + OXM (IPECN _) False -> 1 + OXM (IPProto _) False -> 1 + OXM (TCPSrc _) False -> 2 + OXM (TCPDst _) False -> 2 + OXM (UDPSrc _) False -> 2 + OXM (UDPDst _) False -> 2 + OXM (SCTPSrc _) False -> 2 + OXM (SCTPDst _) False -> 2 + OXM (ICMPv4_Type _) False -> 1 + OXM (ICMPv4_Code _) False -> 1 + OXM (ARP_OP _) False -> 2 + OXM (ARP_SPA _ _) False -> 4 + OXM (ARP_SPA _ _) True -> 4 * 2 + OXM (ARP_TPA _ _) False -> 4 + OXM (ARP_TPA _ _) True -> 4 * 2 + OXM (ARP_SHA _ _) False -> 6 + OXM (ARP_SHA _ _) True -> 6 * 2 + OXM (ARP_THA _ _) False -> 6 + OXM (ARP_THA _ _) True -> 6 * 2 + OXM (IPv6Src _ _) False -> 16 + OXM (IPv6Src _ _) True -> 16 * 2 + OXM (IPv6Dst _ _) False -> 16 + OXM (IPv6Dst _ _) True -> 16 * 2 + OXM (IPv6_FLabel _) False -> 4 + OXM (IPv6_FLabel _) True -> 4 * 2 + OXM (ICMPv6_Type _) False -> 1 + OXM (ICMPv6_Code _) False -> 1 + OXM (IPv6_ND_Target _) False -> 16 + OXM (IPv6_ND_SLL _) False -> 6 + OXM (IPv6_ND_TLL _) False -> 6 + OXM (MPLS_Label _) False -> 4 + OXM (MPLS_TC _) False -> 1 + OXM (MPLS_BOS _) False -> 1 + OXM (PBB_ISID _ _ ) False -> 3 + OXM (PBB_ISID _ _ ) True -> 3 * 2 + OXM (TunnelID _ _) False -> 8 + OXM (TunnelID _ _) True -> 8 * 2 + OXM (IPv6_EXTHDR _) False -> 2 + OXM (IPv6_EXTHDR _) True -> 2 * 2 + + _ -> error ("Unexpected field and mask value: " ++ show oxm) + +tlv_header_len :: Int +tlv_header_len = 4 + +getMatch :: Get Match +getMatch = do + matchType <- getWord16be + matchLen <- getWord16be + assert (matchType /= 0) $ do + oxms <- getOXMs $ fromIntegral matchLen - 4 + let remainder = (- (fromIntegral matchLen :: Int)) `mod` 8 + skip remainder + return $ MatchOXM { oxms = oxms } + +getOXMs :: Int -> Get [OXM] +getOXMs len + | len == 0 = return [] + | len > 0 = do (oxmlen,oxm) <- getOXM + oxms <- getOXMs (len - oxmlen) + return $ oxm:oxms + | otherwise = error "Bad OXM length" + +getOXM :: Get (Int,OXM) +getOXM = do + header <- getWord32be + let len = fromIntegral (header `mod` 0x100) + let oxmClass = fromIntegral (shiftR header 16) + oxmField = clearBit (fromIntegral $ shiftR header 9) 7 + hasMask = testBit header 8 + oxm <- + if oxmClass == 0x8000 + then do toField hasMask oxmField + else if oxmClass == 1 + then assert (len == 4) $ -- Don't yet support masked Nicira registers + do val <- getWord32be + return $ NiciraRegister (fromIntegral oxmField) val + else do payload <- getByteString len + return $ OXMOther { oxmBody = payload + , oxmField = oxmField + , oxmClass = oxmClass + , oxmHasMask = testBit header 8 + } + return (4 + len, oxm) + +toField :: Bool -> Word8 -> Get OXM +toField False 0 = InPort <$> getWord32be +toField False 1 = InPhyPort <$> getWord32be +toField hasMask 2 = + (\x y -> Metadata x y hasMask) <$> + getWord64be <*> if hasMask then getWord64be else return (-1) +toField hasMask 3 = + (\x y -> EthDst x y hasMask) <$> + getEthernetAddress <*> + if hasMask then getEthernetAddress else return (-1) +toField hasMask 4 = + (\x y -> EthSrc x y hasMask) <$> + getEthernetAddress <*> + if hasMask then getEthernetAddress else return (-1) +toField False 5 = EthType <$> getWord16be +toField hasMask 6 = do + v <- getWord16be + if v == 0 + then assert (not hasMask) $ return $ OXM { oxmOFField = VLANID Absent, oxmHasMask = hasMask } + else if hasMask + then do mask' <- getWord16be + assert (mask' == vlan_present_mask) $ + return $ OXM { oxmOFField = VLANID (Present Nothing), oxmHasMask = hasMask } + else return $ OXM { oxmOFField = VLANID (Present $ Just v), oxmHasMask = hasMask } + +toField False 7 = (\x -> OXM { oxmOFField = VLANPCP x, oxmHasMask = False }) <$> getWord8 +toField False 8 = (\x -> OXM { oxmOFField = IPDSCP x, oxmHasMask = False }) <$> getWord8 +toField False 9 = (\x -> OXM { oxmOFField = IPECN x, oxmHasMask = False }) <$> getWord8 +toField False 10 = (\x -> OXM { oxmOFField = IPProto x, oxmHasMask = False }) <$> getWord8 +toField hasMask 11 = + (\x y -> IPv4Src (x // maskToPrefixLength y)) <$> + getIPAddress <*> if hasMask then getIPAddress else return (IPAddress 0xffffffff) +toField hasMask 12 = + (\x y -> IPv4Dst (x // maskToPrefixLength y)) <$> + getIPAddress <*> if hasMask then getIPAddress else return (IPAddress 0xffffffff) +toField False 13 = (\x -> OXM { oxmOFField = TCPSrc x, oxmHasMask = False }) <$> getWord16be +toField False 14 = (\x -> OXM { oxmOFField = TCPDst x, oxmHasMask = False }) <$> getWord16be +toField False 15 = (\x -> OXM { oxmOFField = UDPSrc x, oxmHasMask = False }) <$> getWord16be +toField False 16 = (\x -> OXM { oxmOFField = UDPDst x, oxmHasMask = False }) <$> getWord16be +toField False 17 = (\x -> OXM { oxmOFField = SCTPSrc x, oxmHasMask = False }) <$> getWord16be +toField False 18 = (\x -> OXM { oxmOFField = SCTPDst x, oxmHasMask = False }) <$> getWord16be +toField False 19 = (\x -> OXM { oxmOFField = ICMPv4_Type x, oxmHasMask = False }) <$> getWord8 +toField False 20 = (\x -> OXM { oxmOFField = ICMPv4_Code x, oxmHasMask = False }) <$> getWord8 +toField False 21 = + (\x -> OXM { oxmOFField = ARP_OP x, oxmHasMask = False }) <$> + getWord16be +toField hasMask 22 = + (\x y -> OXM { oxmOFField = ARP_SPA x y, oxmHasMask = hasMask }) <$> + getIPAddress <*> if hasMask then getIPAddress else return (-1) +toField hasMask 23 = + (\x y -> OXM { oxmOFField = ARP_TPA x y, oxmHasMask = hasMask }) <$> + getIPAddress <*> if hasMask then getIPAddress else return (-1) +toField hasMask 24 = + (\x y -> OXM { oxmOFField = ARP_SHA x y, oxmHasMask = hasMask }) <$> + getEthernetAddress <*> if hasMask then getEthernetAddress else return (-1) +toField hasMask 25 = + (\x y -> OXM { oxmOFField = ARP_THA x y, oxmHasMask = hasMask }) <$> + getEthernetAddress <*> if hasMask then getEthernetAddress else return (-1) +toField hasMask 26 = + (\x y -> OXM { oxmOFField = IPv6Src x y, oxmHasMask = hasMask }) <$> + getIPv6Address <*> if hasMask then getIPv6Address else return $ B.replicate 16 (-1) +toField hasMask 27 = + (\x y -> OXM { oxmOFField = IPv6Dst x y, oxmHasMask = hasMask }) <$> + getIPv6Address <*> if hasMask then getIPv6Address else return $ B.replicate 16 (-1) +toField hasMask 38 = do + v <- getWord64be + when hasMask $ void getWord64be + return $ OXM { oxmOFField = TunnelID v (-1), oxmHasMask = hasMask } + +toField _ _ = error "Illegal field code" + +getIPv6Address :: Get IPv6Address +getIPv6Address = getByteString 16 + +getEthernetAddress :: Get EthernetAddress +getEthernetAddress = + do x <- getWord32be + y <- getWord16be + return $ ethernetAddress64 $ pack_32_16 x y + +putEthernetAddress :: EthernetAddress -> Put +putEthernetAddress w = do + let a = unpack64 w + putWord32be $ fromIntegral $ a `shiftR` 16 + putWord16be $ fromIntegral a + +numBodyBytes :: Integral a => Word16 -> a +numBodyBytes len = fromIntegral $ len - len_header + +numMessageBytes :: Integral a => a -> Word16 +numMessageBytes n = len_header + fromIntegral n + +-- =========== CONSTANTS =========== + +len_header :: Word16 +len_header = 8 + +version_of13 :: Word8 +version_of13 = 0x04 + +hello_type_code :: Word8 +hello_type_code = 0 + +error_type_code :: Word8 +error_type_code = 1 + +echo_request_type_code :: Word8 +echo_request_type_code = 2 + +echo_reply_type_code :: Word8 +echo_reply_type_code = 3 + +feature_request_type_code :: Word8 +feature_request_type_code = 5 + +feature_reply_type_code :: Word8 +feature_reply_type_code = 6 + +config_request_type_code :: Word8 +config_request_type_code = 7 + +config_reply_type_code :: Word8 +config_reply_type_code = 8 + +config_set_type_code :: Word8 +config_set_type_code = 9 + +packet_in_type_code :: Word8 +packet_in_type_code = 10 + +flow_removed_type_code :: Word8 +flow_removed_type_code = 11 + +port_status_type_code :: Word8 +port_status_type_code = 12 + +packet_out_type_code :: Word8 +packet_out_type_code = 13 + +flow_mod_type_code :: Word8 +flow_mod_type_code = 14 + +group_mod_type_code :: Word8 +group_mod_type_code = 15 + +port_mod_type_code :: Word8 +port_mod_type_code = 16 + +multipart_request_type_code :: Word8 +multipart_request_type_code = 18 + +multipart_reply_type_code :: Word8 +multipart_reply_type_code = 19 + +barrier_request_type_code :: Word8 +barrier_request_type_code = 20 + +barrier_reply_type_code :: Word8 +barrier_reply_type_code = 21 + +oFPGC_ADD, oFPGC_MODIFY, oFPGC_DELETE :: Word16 +oFPGC_ADD = 0 +oFPGC_MODIFY = 1 +oFPGC_DELETE = 2 + +-- =========== UTILITY =========== +bitSetToSet :: (Ord a, Bits b) => [(Int, a)] -> b -> Set a +bitSetToSet fields bitset = + Set.fromList [ a | (i,a) <- fields, testBit bitset i ] + +setToBitSet :: (Ord a, Bits b, Num b) => [(Int,a)] -> Set a -> b +setToBitSet fields set = + foldl setBit 0 [ i | (i,a) <- fields, Set.member a set ] + +mapToBitSets :: (Ord a, Bits b, Num b) => [(Int,a)] -> Map a Bool -> (b,b) +mapToBitSets fields m = (toBitSet trueSet, toBitSet allSet) + where + trueSet = Set.fromList $ [ a | (a, True) <- Map.assocs m] + allSet = Set.fromList $ Map.keys m + toBitSet = setToBitSet fields diff --git a/src/Network/Data/OF13/Server.hs b/src/Network/Data/OF13/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/OF13/Server.hs @@ -0,0 +1,83 @@ +module Network.Data.OF13.Server + ( Switch + , Factory + , runServer + , runServerOne + , sendMessage + , talk + , talk2 + ) where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.Binary +import Data.Binary.Get +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as S +import Network.Socket hiding (recv) +import Network.Socket.ByteString (recv, sendAll) + +type Factory a = Switch -> IO (Maybe a -> IO ()) +newtype Switch = Switch Socket + +runServer :: Binary a => Int -> Factory a -> IO () +runServer portNum mkHandler = + runServer_ portNum $ \(conn, _) -> + void $ + forkIO $ + bracket + (mkHandler (Switch conn)) + (\handler -> handler Nothing >> sClose conn) + (talk conn) + +runServerOne :: Binary a => Int -> Factory a -> IO () +runServerOne portNum mkHandler = + runServer_ portNum $ \(conn, _) -> + void $ + bracket + (mkHandler (Switch conn)) + (\handler -> handler Nothing >> sClose conn) + (talk conn) + +runServer_ :: Int -> ((Socket, SockAddr) -> IO ()) -> IO () +runServer_ portNum f = withSocketsDo $ + do addrinfos <- getAddrInfo + (Just (defaultHints {addrFlags = [AI_PASSIVE]})) + Nothing + (Just $ show portNum) + let serveraddr = head addrinfos + bracket + (socket (addrFamily serveraddr) Stream defaultProtocol) + sClose + (\sock -> do + setSocketOption sock ReuseAddr 1 + bindSocket sock $ addrAddress serveraddr + listen sock 1 + forever $ accept sock >>= f + ) + +talk :: Binary a => Socket -> (Maybe a -> IO ()) -> IO () +talk = talk2 get + +talk2 :: Get a -> Socket -> (Maybe a -> IO ()) -> IO () +talk2 getter conn handler = go $ runGetIncremental getter + where + go (Fail _ _ err) = error err + go (Partial f) = do + msg <- recv conn bATCH_SIZE + if S.null msg + then return () + else go $ f $ Just msg + go (Done unused _ ofm) = do + handler $ Just ofm + go $ pushChunk (runGetIncremental getter) unused + +bATCH_SIZE :: Int +bATCH_SIZE = 1024 + +sendMessage :: Binary a => Switch -> [a] -> IO () +sendMessage (Switch s) = mapM_ (sendMessage' s) + +sendMessage' :: Binary a => Socket -> a -> IO () +sendMessage' sock = mapM_ (sendAll sock) . L.toChunks . encode diff --git a/src/Network/Data/OpenFlow.hs b/src/Network/Data/OpenFlow.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/OpenFlow.hs @@ -0,0 +1,32 @@ +module Network.Data.OpenFlow ( + module Network.Data.OpenFlow.Action + , module Network.Data.OpenFlow.Error + , module Network.Data.OpenFlow.FlowTable + , module Network.Data.OpenFlow.Match + , module Network.Data.OpenFlow.Messages + , module Network.Data.OpenFlow.MessagesBinary + , module Network.Data.OpenFlow.Packet + , module Network.Data.OpenFlow.Port + , module Network.Data.OpenFlow.Statistics + , module Network.Data.OpenFlow.Switch + , module Network.Data.Ethernet.EthernetAddress + , module Network.Data.Ethernet.EthernetFrame + , module Network.Data.IPv4.IPAddress + , module Network.Data.IPv4.IPPacket + ) where + +import Network.Data.OpenFlow.Action +import Network.Data.OpenFlow.Error +import Network.Data.OpenFlow.FlowTable +import Network.Data.OpenFlow.Match +import Network.Data.OpenFlow.Messages +import Network.Data.OpenFlow.MessagesBinary +import Network.Data.OpenFlow.Packet +import Network.Data.OpenFlow.Port +import Network.Data.OpenFlow.Statistics +import Network.Data.OpenFlow.Switch +import Network.Data.Ethernet.EthernetAddress +import Network.Data.Ethernet.EthernetFrame +import Network.Data.IPv4.IPAddress +import Network.Data.IPv4.IPPacket + diff --git a/src/Network/Data/OpenFlow/Action.hs b/src/Network/Data/OpenFlow/Action.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/OpenFlow/Action.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE BangPatterns #-} + +module Network.Data.OpenFlow.Action ( + -- * Actions + Action (..) + , ActionType (..) + , PseudoPort (..) + , MaxLenToSendController + , VendorID + , QueueID + -- * Action sequences + , ActionSequence(..) + , actionSequenceToList + , actionSequenceSizeInBytes + , sendOnPort, phyPort, 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 Network.Data.OpenFlow.Port +import Network.Data.Ethernet.EthernetAddress +import Network.Data.Ethernet.EthernetFrame +import Network.Data.IPv4.IPAddress +import Network.Data.IPv4.IPPacket +import Data.Word +import Data.Monoid + +-- |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,Ord) + + +-- | A @PseudoPort@ denotes the target of a forwarding +-- action. +data PseudoPort = Flood -- ^send out all physical ports except input port and those disabled by STP + | PhysicalPort PortID -- ^send out physical port with given id + | InPort -- ^send packet out the input port + | 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, Ord) + +-- | 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] +data ActionSequence = ActionSequence !Int ![Action] + deriving (Show, Eq, Ord) + +instance Monoid ActionSequence where + mempty = drop + mappend (ActionSequence s1 a1) (ActionSequence s2 a2) = ActionSequence (s1 + s2) (a1 ++ a2) + +actionSequenceToList :: ActionSequence -> [Action] +actionSequenceToList (ActionSequence _ as) = as + +actionSequenceSizeInBytes :: ActionSequence -> Int +actionSequenceSizeInBytes (ActionSequence !sz _) = sz + +-- | send p is a packet send action. +send :: PseudoPort -> ActionSequence +send p = ActionSequence 8 [SendOutPort p] + +sendOnPort :: PortID -> ActionSequence +sendOnPort = phyPort + +phyPort :: PortID -> ActionSequence +phyPort p = ActionSequence 8 [SendOutPort $ PhysicalPort p] +{-# INLINE phyPort #-} + +sendOnInPort, flood, drop, allPhysicalPorts, processNormally, processWithTable :: ActionSequence +sendOnInPort = send InPort +flood = send Flood +drop = ActionSequence 0 [] +allPhysicalPorts = send AllPhysicalPorts +processNormally = send NormalSwitching +processWithTable = send WithTable + +sendToController :: MaxLenToSendController -> ActionSequence +sendToController maxlen = send (ToController maxlen) + +setVlanVID :: VLANID -> ActionSequence +setVlanVID vlanid = ActionSequence 8 [SetVlanVID vlanid] + +setVlanPriority :: VLANPriority -> ActionSequence +setVlanPriority x = ActionSequence 8 [SetVlanPriority x] + +stripVlanHeader :: ActionSequence +stripVlanHeader = ActionSequence 8 [StripVlanHeader] + +setEthSrcAddr :: EthernetAddress -> ActionSequence +setEthSrcAddr addr = ActionSequence 16 [SetEthSrcAddr addr] + +setEthDstAddr :: EthernetAddress -> ActionSequence +setEthDstAddr addr =ActionSequence 16 [SetEthDstAddr addr] + +setIPSrcAddr :: IPAddress -> ActionSequence +setIPSrcAddr addr = ActionSequence 8 [SetIPSrcAddr addr] + +setIPDstAddr :: IPAddress -> ActionSequence +setIPDstAddr addr = ActionSequence 8 [SetIPDstAddr addr] + +setIPToS :: IPTypeOfService -> ActionSequence +setIPToS tos = ActionSequence 8 [SetIPToS tos] + +setTransportSrcPort :: TransportPort -> ActionSequence +setTransportSrcPort port = ActionSequence 8 [SetTransportSrcPort port] + +setTransportDstPort :: TransportPort -> ActionSequence +setTransportDstPort port = ActionSequence 8 [SetTransportDstPort port] + +enqueue :: PortID -> QueueID -> ActionSequence +enqueue portid queueid = ActionSequence 16 [Enqueue portid queueid] + +vendorAction :: VendorID -> [Word8] -> ActionSequence +vendorAction vid bytes = ActionSequence (length bytes + 8) [VendorAction vid bytes] + + + + diff --git a/src/Network/Data/OpenFlow/Error.hs b/src/Network/Data/OpenFlow/Error.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/OpenFlow/Error.hs @@ -0,0 +1,66 @@ +module Network.Data.OpenFlow.Error ( + SwitchError (..) + , HelloFailure (..) + , RequestError (..) + , ActionError (..) + , FlowModError (..) + , PortModError (..) + , QueueOpError (..) + ) 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] + | BadAction ActionError [Word8] + | FlowModFailed FlowModError [Word8] + | PortModFailed PortModError [Word8] + | QueueOperationFailed QueueOpError [Word8] + deriving (Show, Eq) + +data HelloFailure = IncompatibleVersions + | HelloPermissionsError + deriving (Show, Eq, Ord, Enum) + +data RequestError = VersionNotSupported + | MessageTypeNotSupported + | StatsRequestTypeNotSupported + | VendorNotSupported + | VendorSubtypeNotSupported + | RequestPermissionsError + | BadRequestLength + | BufferEmpty + | UnknownBuffer + deriving (Show, Eq, Ord, Enum) + + +data ActionError = UnknownActionType + | BadActionLength + | UnknownVendorID + | UnknownActionTypeForVendor + | BadOutPort + | BadActionArgument + | ActionPermissionsError + | TooManyActions + | InvalidQueue + deriving (Show, Eq, Ord, Enum) + +data FlowModError = TablesFull + | OverlappingFlow + | FlowModPermissionsError + | EmergencyModHasTimeouts + | BadCommand + | UnsupportedActionList + deriving (Show, Eq, Ord, Enum) + +data PortModError = BadPort + | BadHardwareAddress + deriving (Show, Eq, Ord, Enum) + +data QueueOpError = QueueOpBadPort + | QueueDoesNotExist + | QueueOpPermissionsError + deriving (Show, Eq, Ord, Enum) + diff --git a/src/Network/Data/OpenFlow/FlowTable.hs b/src/Network/Data/OpenFlow/FlowTable.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/OpenFlow/FlowTable.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE BangPatterns #-} + +-- | 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 Network.Data.OpenFlow.FlowTable ( + FlowTableID + , FlowMod (..) + , Cookie + , Priority + , TimeOut (..) + , FlowRemoved (..) + , FlowRemovalReason (..) + ) where + +import Network.Data.OpenFlow.Action +import Network.Data.OpenFlow.Match +import Network.Data.OpenFlow.Packet +import Data.Word + +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 + } + | ModifyFlowStrict { match :: !Match + , priority :: !Priority + , newActions :: !ActionSequence + , ifMissingCookie :: !Cookie + , ifMissingIdleTimeOut :: !TimeOut + , ifMissingHardTimeOut :: !TimeOut + , ifMissingNotifyWhenRemoved :: !Bool + , ifMissingOverlapAllowed :: !Bool + } + | DeleteFlows { match :: !Match, + outPort :: !(Maybe PseudoPort) + } + | DeleteFlowStrict { match :: !Match, + outPort :: !(Maybe PseudoPort), + priority :: !Priority + } + deriving (Show, Eq) + +type Cookie = Word64 + +-- |The priority of a flow entry is a 16-bit integer. Flow entries with higher numeric priorities match before lower ones. +type Priority = Word16 + +-- | Each flow entry has idle and hard timeout values +-- associated with it. +data TimeOut = Permanent + | ExpireAfter !Word16 + deriving (Show,Eq) + + +-- | When a switch removes a flow, it may send a message containing the information +-- in @FlowRemovedRecord@ to the controller. +data FlowRemoved = FlowRemovedRecord { flowRemovedMatch :: !Match, + flowRemovedCookie :: !Word64, + flowRemovedPriority :: !Priority, + flowRemovedReason :: !FlowRemovalReason, + flowRemovedDuration :: !Integer, + flowRemovedDurationNSecs :: !Integer, + flowRemovedIdleTimeout :: !Integer, + flowRemovedPacketCount :: !Integer, + flowRemovedByteCount :: !Integer } + deriving (Show,Eq) + +data FlowRemovalReason = IdleTimerExpired + | HardTimerExpired + | DeletedByController + deriving (Show,Eq,Ord,Enum) + diff --git a/src/Network/Data/OpenFlow/Match.hs b/src/Network/Data/OpenFlow/Match.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/OpenFlow/Match.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE DisambiguateRecordFields, RecordWildCards, NamedFieldPuns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +module Network.Data.OpenFlow.Match ( + Match (..) + , MatchHeader(..) + , MatchBody(..) + , matchAny + , matchAnyHeader + , matchAnyBody + , isExactMatch + , exactMatchPacketNoPort + , frameToExactMatchNoPort + , ofpVlanNone + , matches + , overlap + , matchIntersection + , prettyPrintMatch + ) where + +import Network.Data.Ethernet.EthernetAddress +import Network.Data.Ethernet.EthernetFrame +import Network.Data.Ethernet.AddressResolutionProtocol +import Network.Data.IPv4.IPAddress hiding (intersect) +import qualified Network.Data.IPv4.IPAddress as IPAddress +import qualified Network.Data.IPv4.IPPacket as IP +import Network.Data.IPv4.IPPacket (IPHeader(..)) +import Network.Data.OpenFlow.Port +import Network.Data.OpenFlow.Packet + +import Data.Aeson +import qualified Data.List as List +import Data.Maybe (isJust, catMaybes) +import GHC.Generics + + +-- | Each flow entry includes a match, which essentially defines packet-matching condition. +-- Fields that are left Nothing are "wildcards". +data Match = Match !(Maybe PortID) !MatchHeader !MatchBody + deriving (Show,Read,Eq,Ord,Generic) + +instance ToJSON Match +instance FromJSON Match + +data MatchHeader = MatchHeader { srcEthAddress, dstEthAddress :: !(Maybe EthernetAddress), + vLANID :: !(Maybe VLANID), + vLANPriority :: !(Maybe VLANPriority), + ethFrameType :: !(Maybe EthernetTypeCode) } + deriving (Show,Read,Eq,Ord, Generic) +instance ToJSON MatchHeader +instance FromJSON MatchHeader + +data MatchBody = MatchBody { ipTypeOfService :: !(Maybe IP.IPTypeOfService), + matchIPProtocol :: !(Maybe IP.IPProtocol), + srcIPAddress, dstIPAddress :: !IPAddressPrefix, + srcTransportPort, dstTransportPort :: !(Maybe IP.TransportPort) + } + deriving (Show,Read,Eq,Ord, Generic) +instance ToJSON MatchBody +instance FromJSON MatchBody + +prettyPrintMatch :: Match -> String +prettyPrintMatch (Match ip (MatchHeader seth deth vid vpr etht) (MatchBody tos prot sip dip stp dtp)) = + let mshow _ Nothing = Nothing + mshow prefix (Just v) = Just (prefix ++ show v) + mshowIP _ (_, 0) = Nothing + mshowIP prefix ipPref = Just (prefix ++ IPAddress.showPrefix ipPref) + lst = [ mshow "inPort=" ip, + fmap (\eth -> "srcEth=" ++ prettyPrintEthernetAddress eth) seth, + fmap (\eth -> "dstEth=" ++ prettyPrintEthernetAddress eth) deth, + mshow "vid=" vid, + mshow "vpr=" vpr, + mshow "ethtyp=" etht, + mshow "tos=" tos, + mshow "prot=" prot, + mshowIP "sip=" sip, + mshowIP "dip=" dip, + mshow "stp=" stp, + mshow "dtp=" dtp ] + in "<" ++ List.concat (List.intersperse "," (catMaybes lst)) ++ ">" +-- |A match that matches every packet. +matchAny :: Match +matchAny = Match Nothing matchAnyHeader matchAnyBody + +matchAnyHeader :: MatchHeader +matchAnyHeader = MatchHeader { srcEthAddress = Nothing, + dstEthAddress = Nothing, + vLANID = Nothing, + vLANPriority = Nothing, + ethFrameType = Nothing } + +matchAnyBody :: MatchBody +matchAnyBody = MatchBody { ipTypeOfService = Nothing, + matchIPProtocol = Nothing, + srcIPAddress = defaultIPPrefix, + dstIPAddress = defaultIPPrefix, + srcTransportPort = Nothing, + dstTransportPort = Nothing + } + +matchIntersection :: Match -> Match -> Maybe Match +matchIntersection + (Match inp (MatchHeader seth deth vid vp etp) (MatchBody tos pr sh dh sp dp)) + (Match inp' (MatchHeader seth' deth' vid' vp' etp') (MatchBody tos' pr' sh' dh' sp' dp')) = do + let inter lhs Nothing = Just lhs + inter Nothing rhs = Just rhs + inter (Just l) (Just r) + | l == r = Just (Just l) + | otherwise = Nothing + inPort <- inter inp inp' + srcEth <- inter seth seth' + dstEth <- inter deth deth' + vlanID <- inter vid vid' + vlanPrio <- inter vp vp' + ethTyp <- inter etp etp' + ipTOS <- inter tos tos' + ipProto <- inter pr pr' + srcIP <- IPAddress.intersect sh sh' + dstIP <- IPAddress.intersect dh dh' + srcPort <- inter sp sp' + dstPort <- inter dp dp' + return (Match inPort (MatchHeader srcEth dstEth vlanID vlanPrio ethTyp) (MatchBody ipTOS ipProto srcIP dstIP srcPort dstPort)) + +overlap :: Match -> Match -> Bool +overlap (Match inp (MatchHeader seth deth vid vp etp) (MatchBody tos pr sh dh sp dp)) + (Match inp' (MatchHeader seth' deth' vid' vp' etp') (MatchBody tos' pr' sh' dh' sp' dp')) = + let inm (Just l) (Just r) = l == r + inm _ _ = True + ip = IPAddress.prefixOverlaps + in inm inp inp' && inm seth seth' && inm deth deth' && inm vid vid' && + inm vp vp' && inm etp etp' && inm tos tos' && inm pr pr' && ip sh sh' && + ip dh dh' && inm sp sp' && inm dp dp' + +-- | 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 inPort (MatchHeader {..}) (MatchBody {..})) = + (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 :: Int +ofpVlanNone = 0xffff + +exactMatchPacketNoPort :: PacketInfo -> Match +exactMatchPacketNoPort = frameToExactMatchNoPort . enclosedFrame + +frameToExactMatchNoPort :: EthernetFrame -> Match +frameToExactMatchNoPort (h, body) = + Match Nothing hdr bdy + where + hdr = MatchHeader { srcEthAddress = Just srcEthAddress, + dstEthAddress = Just dstEthAddress, + vLANID = Just vLANID, + vLANPriority = Just vLANPriority, + ethFrameType = Just ethFrameType } + bdy = MatchBody { ipTypeOfService = Just iptos, + matchIPProtocol = Just ipproto, + srcIPAddress = srcip, + dstIPAddress = dstip, + srcTransportPort = Just tsrc, + dstTransportPort = Just tdst + } + + ethFrameType = typeCode body + (srcEthAddress, dstEthAddress, vLANID, vLANPriority) = + case h of + (EthernetHeader {..}) -> + (etherSrc, etherDst, fromIntegral ofpVlanNone, 0) + (Ethernet8021Q {..}) -> + (etherSrc, etherDst, vlanId, priorityCodePoint) + + (iptos, ipproto, srcip, dstip, tsrc, tdst) = + case body of + (IPInEthernet (IPHeader {dscp,ipSrcAddress,ipDstAddress}, ipbody)) -> + let (tsrc',tdst') = + case ipbody of + (IP.TCPInIP s d) -> (s,d) + (IP.UDPInIP s d) -> (s,d) + (IP.ICMPInIP (icmpType,_) _ _) -> (fromIntegral icmpType, 0) + (IP.UninterpretedIPBody _) -> (0,0) + in (dscp, IP.ipProtocol ipbody, exactPrefix ipSrcAddress, exactPrefix ipDstAddress, tsrc', tdst') + + (ARPInEthernet arpPacket) -> + let (ipproto', srcip', dstip') = + case arpPacket of + (ARPQuery (ARPQueryPacket {..})) -> (1, exactPrefix querySenderIPAddress, exactPrefix queryTargetIPAddress) + (ARPReply (ARPReplyPacket {..})) -> (2, exactPrefix replySenderIPAddress, exactPrefix replyTargetIPAddress) + in (0, ipproto', srcip', dstip', 0, 0) + + _ -> (0, 0, defaultIPPrefix, defaultIPPrefix, 0, 0) + + +-- | Models the match semantics of an OpenFlow switch. +matches :: (PortID, EthernetFrame) -> Match -> Bool +matches (inPort, (ethHeader,ethBody)) (Match mInPort (MatchHeader {..}) (MatchBody {..})) = + noneOrEq mInPort inPort + && noneOrEq srcEthAddress (etherSrc ethHeader) + && noneOrEq dstEthAddress (etherDst ethHeader) + && noneOrEq ethFrameType (typeCode ethBody) + && case ethHeader of + { EthernetHeader {} -> True; + Ethernet8021Q {..} -> noneOrEq vLANID vlanId + && noneOrEq vLANPriority priorityCodePoint} + && case ethBody of + { IPInEthernet (hdr,bdy) -> + noneOrEq matchIPProtocol (IP.ipProtocol bdy) + && noneOrEq ipTypeOfService (IP.dscp hdr) + && IP.ipSrcAddress hdr `elemOfPrefix` srcIPAddress + && IP.ipDstAddress hdr `elemOfPrefix` dstIPAddress + && case bdy of + { IP.TCPInIP srcPort dstPort -> + noneOrEq srcTransportPort srcPort + && noneOrEq dstTransportPort dstPort ; + IP.UDPInIP srcPort dstPort -> + noneOrEq srcTransportPort srcPort + && noneOrEq dstTransportPort dstPort ; + _ -> True }; + _ -> True } + +noneOrEq :: Eq a => Maybe a -> a -> Bool +noneOrEq Nothing _ = True +noneOrEq (Just a) a' = a == a' diff --git a/src/Network/Data/OpenFlow/MatchBuilder.hs b/src/Network/Data/OpenFlow/MatchBuilder.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/OpenFlow/MatchBuilder.hs @@ -0,0 +1,332 @@ +{-# LANGUAGE GADTs #-} + +module Network.Data.OpenFlow.MatchBuilder + ( + MatchBuilder + , Error + , Attribute + , match + , matchOrError + , (.&&.) + , (.==.) + , true + , in_port + , vlan_id + , vlan_priority + , eth_src + , eth_dst + , eth_type + , arp + , arp_ip_src + , arp_ip_dst + , ip + , ip_dst + , ip_src + , ip_prot + , ip_dscp + , icmp + , tcp + , tcp_src + , tcp_dst + , udp + , udp_src + , udp_dst + ) where + +import Network.Data.Ethernet.EthernetAddress +import Network.Data.Ethernet.EthernetFrame +import Network.Data.IPv4.IPAddress +import Network.Data.IPv4.IPPacket +import Network.Data.OpenFlow.Match +import Network.Data.OpenFlow.Port +import Data.Bits +import Data.Monoid +import Text.Printf (printf) + +{- +data Match = Match !(Maybe PortID) !MatchHeader !MatchBody + +data MatchHeader = MatchHeader { srcEthAddress, dstEthAddress :: !(Maybe EthernetAddress), + vLANID :: !(Maybe VLANID), + vLANPriority :: !(Maybe VLANPriority), + ethFrameType :: !(Maybe EthernetTypeCode) } + +data MatchBody = MatchBody { ipTypeOfService :: !(Maybe IP.IPTypeOfService), + matchIPProtocol :: !(Maybe IP.IPProtocol), + srcIPAddress, dstIPAddress :: !IPAddressPrefix, + srcTransportPort, dstTransportPort :: !(Maybe IP.TransportPort) + } +-} + +updSrcEthAddress :: MatchHeader -> Maybe EthernetAddress -> MatchHeader +updSrcEthAddress h ma = h { srcEthAddress = ma } + +updDstEthAddress :: MatchHeader -> Maybe EthernetAddress -> MatchHeader +updDstEthAddress h ma = h { dstEthAddress = ma } + +emptyMatch :: Match +emptyMatch = Match Nothing matchAnyHeader matchAnyBody + +true :: MatchBuilder +true = liftBuilder Right + +in_port_ :: PortID -> MatchBuilder +in_port_ pid = liftBuilder $ \m@(Match mInPort hdr bdy) -> + case mInPort of + Nothing -> Right (Match (Just pid) hdr bdy) + Just pid' -> if pid==pid' then Right m else Left "conflicing in_port ids" + +eth_addr_set :: EthernetAddress + -> String + -> (MatchHeader -> Maybe EthernetAddress -> MatchHeader) + -> (MatchHeader -> Maybe EthernetAddress) + -> MatchBuilder +eth_addr_set addr name set get = + liftBuilder $ \m@(Match mInPort hdr bdy) -> + case get hdr of + Nothing -> Right (Match mInPort (set hdr (Just addr)) bdy) + Just addr' -> if addr==addr' then Right m else Left (printf "conflicing %s addresses" name) + +eth_src_ :: EthernetAddress -> MatchBuilder +eth_src_ addr = eth_addr_set addr "eth_src" updSrcEthAddress srcEthAddress + +eth_dst_ :: EthernetAddress -> MatchBuilder +eth_dst_ addr = eth_addr_set addr "eth_dst" updDstEthAddress dstEthAddress + +updateSrcIPAddress, updateDstIPAddress :: IPAddressPrefix -> MatchBody -> MatchBody +updateSrcIPAddress prefix body = body { srcIPAddress = prefix} +updateDstIPAddress prefix body = body { dstIPAddress = prefix} + +vlan_id_ :: VLANID -> MatchBuilder +vlan_id_ vid = liftBuilder $ \m@(Match mInPort hdr bdy) -> + case vLANID hdr of + Nothing -> Right (Match mInPort (hdr { vLANID = Just vid }) bdy) + Just vid' | vid' == vid -> Right m + | otherwise -> Left $ printf "conflicting vlan ids. Was %d, expecting %d" vid' vid + +vlan_priority_ :: VLANPriority -> MatchBuilder +vlan_priority_ pcp = liftBuilder $ \m@(Match mInPort hdr bdy) -> + case vLANPriority hdr of + Nothing -> Right (Match mInPort (hdr { vLANPriority = Just pcp }) bdy) + Just pcp' | pcp' == pcp -> Right m + | otherwise -> Left $ printf "conflicting vlan priorities. Was %d, expecting %d" pcp' pcp + +eth_type_ :: EthernetTypeCode -> MatchBuilder +eth_type_ c = liftBuilder $ \m@(Match mInPort hdr bdy) -> + case ethFrameType hdr of + Nothing -> Right (Match mInPort (hdr { ethFrameType = Just c }) bdy) + Just typ | typ == c -> Right m + | otherwise -> Left $ printf "conflicting eth types. Was %d, expecting %d" typ c + +arp :: MatchBuilder +arp = liftBuilder $ \(Match mInPort hdr bdy) -> + case ethFrameType hdr of + Nothing -> Right (Match mInPort (hdr { ethFrameType = Just ethTypeARP }) bdy) + Just typ | typ == ethTypeARP -> Right (Match mInPort hdr bdy) + | otherwise -> Left "ACK conflicting L3 packet types" + +arp_ip_src_ :: IPAddressPrefix -> MatchBuilder +arp_ip_src_ prefix = liftBuilder $ \(Match mInPort hdr bdy) -> + let bdy' = bdy { srcIPAddress = prefix} in + case ethFrameType hdr of + Nothing -> Right (Match mInPort (hdr { ethFrameType = Just ethTypeARP }) bdy') + Just typ | typ == ethTypeARP -> Right (Match mInPort hdr bdy') + | otherwise -> Left "ACK conflicting L3 packet types" + +arp_ip_dst_ :: IPAddressPrefix -> MatchBuilder +arp_ip_dst_ prefix = liftBuilder $ \(Match mInPort hdr bdy) -> + let bdy' = bdy { dstIPAddress = prefix} in + case ethFrameType hdr of + Nothing -> Right (Match mInPort (hdr { ethFrameType = Just ethTypeARP }) bdy') + Just typ | typ == ethTypeARP -> Right (Match mInPort hdr bdy') + | otherwise -> Left "ACK conflicting L3 packet types" + +ip :: MatchBuilder +ip = liftBuilder $ \(Match mInPort hdr bdy) -> + case ethFrameType hdr of + Nothing -> Right (Match mInPort (hdr { ethFrameType = Just ethTypeIP }) bdy) + Just typ | typ == ethTypeIP -> Right (Match mInPort hdr bdy) + | otherwise -> Left "conflicting L3 packet types" + +set_ip_field :: (MatchBody -> MatchBody) -> MatchBuilder +set_ip_field set = liftBuilder $ \(Match mInPort hdr bdy) -> + case ethFrameType hdr of + Nothing -> Right (Match mInPort (hdr { ethFrameType = Just ethTypeIP }) (set bdy)) + Just typ | typ == ethTypeIP -> Right (Match mInPort hdr (set bdy)) + | otherwise -> Left "conflicting L3 packet types" + +ip_dst_ :: IPAddressPrefix -> MatchBuilder +ip_dst_ = set_ip_field . updateDstIPAddress + +ip_src_ :: IPAddressPrefix -> MatchBuilder +ip_src_ = set_ip_field . updateSrcIPAddress + +dscp_ :: DifferentiatedServicesCodePoint -> MatchBuilder +dscp_ x = set_ip_field (\bdy -> bdy { ipTypeOfService = Just (shiftL x 2) }) + +icmp :: MatchBuilder +icmp = set_ip_field (\bdy -> bdy { matchIPProtocol = Just ipTypeIcmp }) + +tcp :: MatchBuilder +tcp = set_ip_field (\bdy -> bdy { matchIPProtocol = Just ipTypeTcp }) + +udp :: MatchBuilder +udp = set_ip_field (\bdy -> bdy { matchIPProtocol = Just ipTypeUdp }) + +ip_prot_ :: IPProtocol -> MatchBuilder +ip_prot_ p = set_ip_field (\bdy -> bdy { matchIPProtocol = Just p }) + +tcp_src_ :: TCPPortNumber -> MatchBuilder +tcp_src_ = set_tcp_field . updateTransportSrc + +tcp_dst_ :: TCPPortNumber -> MatchBuilder +tcp_dst_ = set_tcp_field . updateTransportDst + +udp_src_ :: TCPPortNumber -> MatchBuilder +udp_src_ = set_udp_field . updateTransportSrc + +udp_dst_ :: TCPPortNumber -> MatchBuilder +udp_dst_ = set_udp_field . updateTransportDst + +updateTransportSrc :: TCPPortNumber -> MatchBody -> MatchBody +updateTransportSrc s bdy = bdy { srcTransportPort = Just s } + +updateTransportDst :: TCPPortNumber -> MatchBody -> MatchBody +updateTransportDst s bdy = bdy { dstTransportPort = Just s } + +set_tcp_field :: (MatchBody -> MatchBody) -> MatchBuilder +set_tcp_field = set_transport_field ipTypeTcp + +set_udp_field :: (MatchBody -> MatchBody) -> MatchBuilder +set_udp_field = set_transport_field ipTypeUdp + +set_transport_field :: IPProtocol -> (MatchBody -> MatchBody) -> MatchBuilder +set_transport_field prot' set = liftBuilder $ \(Match mInPort hdr bdy) -> + case ethFrameType hdr of + Nothing -> + let hdr' = hdr { ethFrameType = Just ethTypeIP } + bdy' = set (bdy { matchIPProtocol = Just prot' }) + in Right $ Match mInPort hdr' bdy' + Just typ + | typ == ethTypeIP -> + case matchIPProtocol bdy of + Nothing -> let bdy' = set (bdy { matchIPProtocol = Just prot' }) + in Right $ Match mInPort hdr bdy' + Just prot | prot == prot' -> Right $ Match mInPort hdr (set bdy) + | otherwise -> Left "conflicting transport layer types" + | otherwise -> Left "Cannot set transport field of non-IP frame" + +newtype MatchBuilder = MatchBuilder (Either Error Match -> Either Error Match) +type Error = String + +instance Monoid MatchBuilder where + mempty = MatchBuilder id + mappend (MatchBuilder f) (MatchBuilder g) = MatchBuilder (f.g) + +(.&&.) :: MatchBuilder -> MatchBuilder -> MatchBuilder +(.&&.) = mappend + +data Attribute a where + ETH_SRC :: Attribute EthernetAddress + ETH_DST :: Attribute EthernetAddress + ETH_TYP :: Attribute EthernetTypeCode + VLAN_ID :: Attribute VLANID + VLAN_PRIORITY :: Attribute VLANPriority + ARP_IP_SRC :: Attribute IPAddressPrefix + ARP_IP_DST :: Attribute IPAddressPrefix + IP_SRC :: Attribute IPAddressPrefix + IP_DST :: Attribute IPAddressPrefix + IP_PROT :: Attribute IPProtocol + IP_DSCP :: Attribute DifferentiatedServicesCodePoint + TCP_SRC :: Attribute TCPPortNumber + TCP_DST :: Attribute TCPPortNumber + UDP_SRC :: Attribute TCPPortNumber + UDP_DST :: Attribute TCPPortNumber + IN_PORT :: Attribute PortID + +in_port :: Attribute PortID +in_port = IN_PORT + +vlan_id :: Attribute VLANID +vlan_id = VLAN_ID + +vlan_priority :: Attribute VLANPriority +vlan_priority = VLAN_PRIORITY + +eth_src :: Attribute EthernetAddress +eth_src = ETH_SRC + +eth_dst :: Attribute EthernetAddress +eth_dst = ETH_DST + +eth_type :: Attribute EthernetTypeCode +eth_type = ETH_TYP + +arp_ip_src :: Attribute IPAddressPrefix +arp_ip_src = ARP_IP_SRC + +arp_ip_dst :: Attribute IPAddressPrefix +arp_ip_dst = ARP_IP_DST + +ip_src :: Attribute IPAddressPrefix +ip_src = IP_SRC + +ip_dst :: Attribute IPAddressPrefix +ip_dst = IP_DST + +ip_prot :: Attribute IPProtocol +ip_prot = IP_PROT + +ip_dscp :: Attribute DifferentiatedServicesCodePoint +ip_dscp = IP_DSCP + +tcp_src :: Attribute TCPPortNumber +tcp_src = TCP_SRC + +tcp_dst :: Attribute TCPPortNumber +tcp_dst = TCP_DST + +udp_src :: Attribute TCPPortNumber +udp_src = UDP_SRC + +udp_dst :: Attribute TCPPortNumber +udp_dst = UDP_DST + +(.==.) :: Attribute a -> a -> MatchBuilder +(.==.) VLAN_ID vid = vlan_id_ vid +(.==.) VLAN_PRIORITY pcp = vlan_priority_ pcp +(.==.) IN_PORT p = in_port_ p +(.==.) ETH_DST addr = eth_dst_ addr +(.==.) ETH_SRC addr = eth_src_ addr +(.==.) ETH_TYP c = eth_type_ c +(.==.) ARP_IP_SRC addr = arp_ip_src_ addr +(.==.) ARP_IP_DST addr = arp_ip_dst_ addr +(.==.) IP_DST addr = ip_dst_ addr +(.==.) IP_SRC addr = ip_src_ addr +(.==.) IP_PROT p = ip_prot_ p +(.==.) IP_DSCP x = dscp_ x +(.==.) TCP_DST s = tcp_dst_ s +(.==.) TCP_SRC s = tcp_src_ s +(.==.) UDP_DST s = udp_dst_ s +(.==.) UDP_SRC s = udp_src_ s + +infixr 4 .&&. +infix 6 .==. + + +liftBuilder :: (Match -> Either Error Match) -> MatchBuilder +liftBuilder f = MatchBuilder $ \x -> + case x of + Left e -> Left e + Right m -> f m + +match :: MatchBuilder -> Match +match b = + case matchOrError b of + Left e -> error e + Right m -> m + +matchOrError :: MatchBuilder -> Either Error Match +matchOrError (MatchBuilder f) = f (Right emptyMatch) + + diff --git a/src/Network/Data/OpenFlow/Messages.hs b/src/Network/Data/OpenFlow/Messages.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/OpenFlow/Messages.hs @@ -0,0 +1,58 @@ +{-| +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 Network.Data.OpenFlow.Messages ( + TransactionID + , SCMessage (..) + , CSMessage (..) + ) where + +import Control.DeepSeq.Generics +import Data.Word +import qualified Network.Data.OpenFlow.Port as Port +import qualified Network.Data.OpenFlow.Packet as Packet +import Network.Data.OpenFlow.Switch +import qualified Network.Data.OpenFlow.FlowTable as FlowTable +import Network.Data.OpenFlow.Statistics +import Network.Data.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 TransactionID -- ^ Sent after a switch establishes a TCP connection to the controller + | SCEchoRequest TransactionID ![Word8] -- ^ Switch requests an echo reply + | SCEchoReply TransactionID ![Word8] -- ^ Switch responds to an echo request + | Features TransactionID !SwitchFeatures -- ^ Switch reports its features + | PacketIn TransactionID !Packet.PacketInfo -- ^ Switch sends a packet to the controller + | PortStatus TransactionID !Port.PortStatus -- ^ Switch sends port status + | FlowRemoved TransactionID !FlowTable.FlowRemoved -- ^ Switch reports that a flow has been removed + | StatsReply TransactionID !StatsReply -- ^ Switch reports statistics + | Error TransactionID !SwitchError -- ^ Switch reports an error + | BarrierReply TransactionID -- ^ Switch responds that a barrier has been processed + | QueueConfigReply TransactionID !QueueConfigReply + deriving (Show,Eq) + +instance NFData SCMessage + +-- |The controller can send these messages to the switch. +data CSMessage + = CSHello TransactionID -- ^ Controller must send hello before sending any other messages + | CSEchoRequest TransactionID ![Word8] -- ^ Controller requests a switch echo + | CSEchoReply TransactionID ![Word8] -- ^ Controller responds to a switch echo request + | FeaturesRequest TransactionID -- ^ Controller requests features information + | PacketOut TransactionID !Packet.PacketOut -- ^ Controller commands switch to send a packet + | FlowMod TransactionID !FlowTable.FlowMod -- ^ Controller modifies a switch flow table + | PortMod TransactionID !Port.PortMod -- ^ Controller configures a switch port + | StatsRequest TransactionID !StatsRequest -- ^ Controller requests statistics + | BarrierRequest TransactionID -- ^ Controller requests a barrier + | SetConfig TransactionID + | ExtQueueModify TransactionID !Port.PortID ![QueueConfig] + | ExtQueueDelete TransactionID !Port.PortID ![QueueConfig] + | Vendor TransactionID + | GetQueueConfig TransactionID !QueueConfigRequest + deriving (Show,Eq) diff --git a/src/Network/Data/OpenFlow/MessagesBinary.hs b/src/Network/Data/OpenFlow/MessagesBinary.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/OpenFlow/MessagesBinary.hs @@ -0,0 +1,1721 @@ +{-# 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 Network.Data.OpenFlow.MessagesBinary + ( + getCSMessage + , putCSMessage + , getSCMessage + , putSCMessage + ) where + +import Network.Data.Ethernet.EthernetAddress +import Network.Data.Ethernet.EthernetFrame +import Network.Data.IPv4.IPAddress +import qualified Network.Data.OpenFlow.Messages as M +import Network.Data.OpenFlow.Port +import Network.Data.OpenFlow.Action +import Network.Data.OpenFlow.Switch +import Network.Data.OpenFlow.Match +import Network.Data.OpenFlow.Packet +import Network.Data.OpenFlow.FlowTable +import Network.Data.OpenFlow.Statistics +import Network.Data.OpenFlow.Error +import Control.Applicative +import Control.DeepSeq.Generics +import Control.Monad (when) +import Data.Monoid hiding ((<>), mconcat) +import Data.Word +import Data.Bits +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get +import qualified Data.ByteString as B +import Data.List as List +import Data.Char (chr) +import qualified Data.Map as Map +import Data.Bimap (Bimap, (!), (!>)) +import qualified Data.Bimap as Bimap +import Data.Char (ord) + + + +instance Binary M.SCMessage where + get = getSCMessage + put = putSCMessage + +instance Binary M.CSMessage where + put = putCSMessage + get = getCSMessage + +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.SCMessage +getSCMessage + = do hdr <- getHeader + bdy <- getSCMessageBody (msgTransactionID hdr) (msgType hdr) (fromIntegral $ msgLength hdr) + return bdy + +-- | Parser for @CSMessage@s +getCSMessage :: Get M.CSMessage +getCSMessage = do hdr <- getHeader + snd <$> getCSMessageBody hdr + + +-- | Unparser for @SCMessage@s +putSCMessage :: M.SCMessage -> Put +putSCMessage msg = + case msg of + M.SCHello xid -> putH xid ofptHello headerSize + + M.SCEchoRequest xid bytes -> putH xid ofptEchoRequest (headerSize + length bytes) <> + putWord8s bytes + M.SCEchoReply xid bytes -> putH xid ofptEchoReply (headerSize + length bytes) <> + putWord8s bytes + M.PacketIn xid pktInfo -> let bodyLen = packetInMessageBodyLen pktInfo + in putH xid ofptPacketIn (headerSize + bodyLen) <> + putPacketInRecord pktInfo + M.Features xid features -> putH xid ofptFeaturesReply (headerSize + 24 + 48 * length (ports features)) <> + putSwitchFeaturesRecord features + M.Error xid err -> putH xid ofptError (headerSize + 2 + 2) <> + putSwitchError err + _ -> error ("serialization for message " ++ show msg ++ " is not yet supported.") + where vid = ofpVersion + putH xid tcode len = putHeader (OFPHeader vid tcode (fromIntegral len) xid) + +packetInMessageBodyLen :: PacketInfo -> Int +packetInMessageBodyLen pktInfo = 10 + fromIntegral (packetLength pktInfo) + +putPacketInRecord :: PacketInfo -> Put +putPacketInRecord (PacketInfo {..}) = + putWord32be (maybe 0xffffffff id bufferID) <> + (putWord16be $ fromIntegral packetLength ) <> + putWord16be receivedOnPort <> + (putWord8 $ reason2Code reasonSent) <> + putWord8 0 + + +{- Header -} + +type OpenFlowVersionID = Word8 + +ofpVersion :: OpenFlowVersionID +ofpVersion = 0x01 + +-- | OpenFlow message header +data OFPHeader = + OFPHeader { msgVersion :: !OpenFlowVersionID + , msgType :: !MessageTypeCode + , msgLength :: !Word16 + , msgTransactionID :: !M.TransactionID + } deriving (Show,Eq) + +instance NFData OFPHeader + +headerSize :: Int +headerSize = 8 + +-- | Unparser for OpenFlow message header +putHeader :: OFPHeader -> Put +putHeader (OFPHeader {..}) = putWord8 msgVersion <> + putWord8 msgType <> + putWord16be msgLength <> + putWord32be msgTransactionID + +putHeaderInternal :: MessageTypeCode -> Word16 -> M.TransactionID -> Put +putHeaderInternal !t !l !x + = putWord8 ofpVersion <> + putWord8 t <> + putWord16be l <> + putWord32be x +{-# INLINE putHeaderInternal #-} + +-- | 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 :: M.TransactionID -> MessageTypeCode -> Int -> Get M.SCMessage +getSCMessageBody !xid !msgType !len + | msgType == ofptPacketIn = do packetInRecord <- getPacketInRecord len + return (M.PacketIn xid packetInRecord) + | msgType == ofptEchoRequest = do bytes <- getWord8s (len - headerSize) + return (M.SCEchoRequest xid bytes) + | msgType == ofptEchoReply = do bytes <- getWord8s (len - headerSize) + return (M.SCEchoReply xid bytes) + | msgType == ofptFeaturesReply = do switchFeaturesRecord <- getSwitchFeaturesRecord len + return (M.Features xid switchFeaturesRecord) + | msgType == ofptHello = return (M.SCHello xid ) + | msgType == ofptPortStatus = do body <- getPortStatus + return (M.PortStatus xid body) + | msgType == ofptError = do body <- getSwitchError len + return (M.Error xid body) + | msgType == ofptFlowRemoved = do body <- getFlowRemovedRecord + return (M.FlowRemoved xid body) + | msgType == ofptBarrierReply = return $ M.BarrierReply xid + | msgType == ofptStatsReply = do body <- getStatsReply len + return (M.StatsReply xid body) + | msgType == ofptQueueGetConfigReply = do qcReply <- getQueueConfigReply len + return (M.QueueConfigReply xid qcReply) + | otherwise = error ("Unrecognized message type: " ++ show msgType) + + + +getCSMessageBody :: OFPHeader -> Get (M.TransactionID, M.CSMessage) +getCSMessageBody header@(OFPHeader {..}) = + if msgType == ofptPacketOut + then do packetOut <- getPacketOut len + return (msgTransactionID, M.PacketOut msgTransactionID packetOut) + else if msgType == ofptFlowMod + then do fmod <- getFlowMod len + return (msgTransactionID, M.FlowMod msgTransactionID fmod) + else if msgType == ofptHello + then return (msgTransactionID, M.CSHello msgTransactionID) + else if msgType == ofptEchoRequest + then do bytes <- getWord8s (len - headerSize) + return (msgTransactionID, M.CSEchoRequest msgTransactionID bytes) + else if msgType == ofptEchoReply + then do bytes <- getWord8s (len - headerSize) + return (msgTransactionID, M.CSEchoReply msgTransactionID bytes) + else if msgType == ofptFeaturesRequest + then return (msgTransactionID, M.FeaturesRequest msgTransactionID) + else if msgType == ofptSetConfig + then do _ <- getSetConfig + return (msgTransactionID, M.SetConfig msgTransactionID) + else if msgType == ofptVendor + then do () <- getVendorMessage len + return (msgTransactionID, M.Vendor msgTransactionID) + 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 :: Int -> Get () +getVendorMessage r + = do skip r + return () + +------------------------------------------- +-- SWITCH FEATURES PARSER +------------------------------------------- +putSwitchFeaturesRecord :: SwitchFeatures -> Put +putSwitchFeaturesRecord (SwitchFeatures {..}) = + putWord64be switchID <> + (putWord32be $ fromIntegral packetBufferSize) <> + (putWord8 $ fromIntegral numberFlowTables) <> + (sequence_ $ replicate 3 (putWord8 0)) <> + (putWord32be $ switchCapabilitiesBitVector capabilities) <> + (putWord32be $ actionTypesBitVector supportedActions) <> + mconcat [ putPhyPort p | p <- ports ] + +getSwitchFeaturesRecord :: Int -> Get SwitchFeatures +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 {..}) = + putWord16be portID <> + putEthernetAddress portAddress <> + (putWord8s $ 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 :: Int +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, ofppsStpBlock, ofppsStpMask :: 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 capList + where inBMap attr = let mask = switchCapability2BitMask attr + in mask .&. bmap == mask + capList = [ HasFlowStats + , HasTableStats + , HasPortStats + , SpanningTree + , CanReassembleIPFragments + , HasQueueStatistics + , CanMatchIPAddressesInARPPackets + ] + +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 +switchCapability2BitMask CanReassembleIPFragments = shiftL 1 5 +switchCapability2BitMask HasQueueStatistics = shiftL 1 6 +switchCapability2BitMask CanMatchIPAddressesInARPPackets = shiftL 1 7 +switchCapability2BitMask MayTransmitOverMultiplePhysicalInterfaces = + error "No encoding defined for MayTransmitOverMultiplePhysicalInterfaces" + + +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 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 + _ -> error "Unknown action type code" +{-# 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 #-} + + + +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 + let !reason = code2Reason reasonCode + (!hdr, bdy) <- lookAhead getEthernetFrame + rawBytes' <- getByteString $ fromIntegral data_len + return $ PacketInfo + { bufferID = if bufID == 0xffffffff then Nothing else Just bufID + , packetLength = fromIntegral totalLen + , receivedOnPort = in_port + , reasonSent = reason + , enclosedFrame = (hdr,bdy) + , rawBytes = rawBytes' + } + 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 :: (Eq a, Num a, Show a) => + a -> PortStatusUpdateReason +code2PortStatusUpdateReason code + | code == 0 = PortAdded + | code == 1 = PortDeleted + | code == 2 = PortModified + | otherwise = 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 []) = + putWord16be 1 <> + putWord16be 3 +putSwitchError err = error ("Serialization for error " ++ show err ++ " not yet supported.") + +code2ErrorType :: Word16 -> Word16 -> [Word8] -> SwitchError +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" + | otherwise = error "Unknown error type code" + + +helloErrorCodesMap :: Bimap Word16 HelloFailure +helloErrorCodesMap = Bimap.fromList [ (0, IncompatibleVersions) + , (1 , HelloPermissionsError) + ] + +requestErrorCodeMap :: Bimap Word16 RequestError +requestErrorCodeMap = Bimap.fromList [ (0, VersionNotSupported), + (1 , MessageTypeNotSupported), + (2 , StatsRequestTypeNotSupported), + (3 , VendorNotSupported), + (4, VendorSubtypeNotSupported) + , (5 , RequestPermissionsError) + , (6 , BadRequestLength) + , (7, BufferEmpty) + , (8, UnknownBuffer) + ] + +actionErrorCodeMap :: Bimap Word16 ActionError +actionErrorCodeMap = Bimap.fromList [ (0, UnknownActionType), + (1, BadActionLength), + (2, UnknownVendorID), + (3, UnknownActionTypeForVendor), + (4, BadOutPort), + (5, BadActionArgument) + , (6, ActionPermissionsError) + , (7, TooManyActions) + , (8, InvalidQueue) + ] + +flowModErrorCodeMap :: Bimap Word16 FlowModError +flowModErrorCodeMap = Bimap.fromList [ (0, TablesFull) + , (1, OverlappingFlow) + , (2, FlowModPermissionsError) + , (3, EmergencyModHasTimeouts) + , (4, BadCommand) + , (5, UnsupportedActionList) + ] + + +------------------------------------------ +-- FlowRemoved parser +------------------------------------------ +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) + + +flowRemovalReason2CodeBijection :: Bimap FlowRemovalReason Word8 +flowRemovalReason2CodeBijection = + Bimap.fromList [(IdleTimerExpired, 0), + (HardTimerExpired, 1), + (DeletedByController, 2) ] + +code2FlowRemovalReason :: Word8 -> FlowRemovalReason +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 statsType == ofpstQueue + then do queueStats <- getQueueStatsReplies bodyLen + return (QueueStatsReply moreFlag queueStats) + else + error ("unhandled stats reply message with type: " ++ show statsType) + + +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 }) + + +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 + , datapathDesc = dp + } ) + 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 ] + _ <- 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 + !dur_nanosec <- getWord32be + !priority <- getWord16be + !idle_to <- getWord16be + !hard_to <- getWord16be + skip 6 + !cookie <- getWord64be + !packet_count <- getWord64be + !byte_count <- getWord64be + actions <- getActionsOfSize (fromIntegral len - flowStatsReplySize) + let !stats = FlowStats { flowStatsTableID = tid, + flowStatsMatch = match, + flowStatsDurationSeconds = fromIntegral dur_sec, + flowStatsDurationNanoseconds = fromIntegral dur_nanosec, + flowStatsPriority = priority, + flowStatsIdleTimeout = fromIntegral idle_to, + flowStatsHardTimeout = fromIntegral hard_to, + flowStatsCookie = cookie, + flowStatsPacketCount = fromIntegral packet_count, + flowStatsByteCount = fromIntegral byte_count, + flowStatsActions = actions } + return (stats, fromIntegral len) + where flowStatsReplySize = 88 + +getActionsOfSize :: Int -> Get [Action] +getActionsOfSize n + | n > 0 = do a <- getAction + as <- getActionsOfSize (n - actionSizeInBytes a) + return (a : as) + | n == 0 = return [] + | otherwise = error "bad number of actions or bad action size" + +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 + | otherwise = error "Unknown pseudo-port code" +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) +getActionForType SetIPTypeOfServiceType _ = + do tos <- getWord8 + skip 3 + return (SetIPToS tos) +getActionForType SetTransportSrcPortType _ = + do port <- getWord16be + return (SetTransportSrcPort port) +getActionForType SetTransportDstPortType _ = + do port <- getWord16be + return (SetTransportDstPort port) +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) + + + +getAggregateStatsReplies :: Int -> Get AggregateFlowStats +getAggregateStatsReplies _ = 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 +---------------------------------------------- + +putCSMessage :: M.CSMessage -> Put +putCSMessage !msg = + case msg of + M.FlowMod xid fmod -> putFlowModMain xid fmod + M.PacketOut xid packetOut -> putSendPacket xid packetOut + M.CSHello xid -> putH xid ofptHello headerSize + M.CSEchoRequest xid bytes -> putH xid ofptEchoRequest (headerSize + length bytes) <> + putWord8s bytes + M.CSEchoReply xid bytes -> putEchoReply xid bytes + M.FeaturesRequest xid -> putFeatureRequest xid + M.PortMod xid portModRecord -> putH xid ofptPortMod portModLength <> + putPortMod portModRecord + M.BarrierRequest xid -> putBarrierRequest xid + M.StatsRequest xid request -> putH xid ofptStatsRequest (statsRequestSize request) <> + putStatsRequestBody request + M.GetQueueConfig xid request -> putH xid ofptQueueGetConfigRequest 12 <> + putQueueConfigRequest request + M.ExtQueueModify xid p qCfgs -> putExtQueueModify xid p qCfgs + M.ExtQueueDelete xid p qCfgs -> putExtQueueDelete xid p qCfgs + _ -> error ("Serialization of message " ++ show msg ++ " not yet supported.") + where vid = ofpVersion + putH :: M.TransactionID -> MessageTypeCode -> Int -> Put + putH xid tcode len = putHeader (OFPHeader vid tcode (fromIntegral len) xid) +{-# INLINE putCSMessage #-} + +putBarrierRequest :: M.TransactionID -> Put +putBarrierRequest xid = + putHeaderInternal ofptBarrierRequest (fromIntegral headerSize) xid + +putFeatureRequest :: M.TransactionID -> Put +putFeatureRequest xid = + putHeaderInternal ofptFeaturesRequest (fromIntegral headerSize) xid + +putEchoReply :: M.TransactionID -> [Word8] -> Put +putEchoReply xid bytes = + putHeaderInternal ofptEchoReply (fromIntegral (headerSize + length bytes)) xid <> + putWord8s bytes + + +putQueueConfigRequest :: QueueConfigRequest -> Put +putQueueConfigRequest (QueueConfigRequest portID) = + putWord16be portID <> + putWord16be 0 --padding + +putExtQueueModify :: M.TransactionID -> PortID -> [QueueConfig] -> Put +putExtQueueModify xid p qCfgs + = putHeaderInternal ofptVendor (fromIntegral (headerSize + 16 + sum (map lenQueueConfig qCfgs))) xid <> + putWord32be 0x000026e1 <> -- OPENFLOW_VENDOR_ID + putWord32be 0 <> -- OFP_EXT_QUEUE_MODIFY + putWord16be p <> + putWord32be 0 <> + putWord16be 0 <> + mconcat (map putQueueConfig qCfgs) + +putExtQueueDelete :: M.TransactionID -> PortID -> [QueueConfig] -> Put +putExtQueueDelete xid p qCfgs + = putHeaderInternal ofptVendor (fromIntegral (headerSize + 16 + sum (map lenQueueConfig qCfgs)) ) xid <> + putWord32be 0x000026e1 <> -- OPENFLOW_VENDOR_ID + putWord32be 1 <> -- OFP_EXT_QUEUE_DELETE + putWord16be p <> + putWord32be 0 <> + putWord16be 0 <> + mconcat (map putQueueConfig qCfgs) + +-- struct ofp_packet_queue +putQueueConfig :: QueueConfig -> Put +putQueueConfig (QueueConfig qid props) = + putWord32be qid <> + putWord16be (fromIntegral (8 + sum (map lenQueueProp props))) <> + putWord16be 0 <> -- padding + mapM_ putQueueProp props + +-- struct ofp_queue_prop_min_rate +putQueueProp :: QueueProperty -> Put +putQueueProp (MinRateQueue (Enabled rate)) = + putWord16be 1 <> -- OFPQT_MIN_RATE + putWord16be 16 <> -- length + putWord32be 0 <> -- padding + putWord16be rate <> + putWord32be 0 <> -- padding + putWord16be 0 --padding +putQueueProp prop = error ("Serialization of queue property " ++ + show prop ++ " not yet supported.") + +lenQueueConfig :: QueueConfig -> Int +lenQueueConfig (QueueConfig _ props) + = 8 + sum (map lenQueueProp props) + +lenQueueProp :: QueueProperty -> Int +lenQueueProp (MinRateQueue _) = 16 + +------------------------------------------ +-- Unparser for packet out message +------------------------------------------ + +sendPacketSizeInBytes :: PacketOut -> Int +sendPacketSizeInBytes (!PacketOutRecord bufferIDData _ actions) = + 16 {- 16 == headerSize + 4 + 2 + 2 -} + + actionSequenceSizeInBytes actions + + case bufferIDData of { Left _ -> 0 ; Right xs -> fromIntegral (B.length xs) } + + +putSendPacket_ :: PacketOut -> Put +putSendPacket_ (PacketOutRecord {..}) = + (putWord32be $ either id (const (-1)) bufferIDData) <> + putWord16be (maybe ofppNone id packetInPort) <> + putWord16be (fromIntegral actionArraySize) <> + (putActions $ actionSequenceToList packetActions) <> + (either (const $ return ()) putByteString bufferIDData) + where actionArraySize = actionSequenceSizeInBytes packetActions + +{-# INLINE putSendPacket #-} +putSendPacket :: M.TransactionID -> PacketOut -> Put +putSendPacket xid pkt = + putHeaderInternal ofptPacketOut (fromIntegral $ sendPacketSizeInBytes pkt) xid <> + putSendPacket_ pkt + +getPacketOut :: Int -> Get PacketOut +getPacketOut len = do + bufID' <- getWord32be + port' <- getWord16be + actionArraySize' <- getWord16be + actions <- getActionsOfSize (fromIntegral actionArraySize') + 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 = ActionSequence (error "unknown size") actions + } + +------------------------------------------ +-- Unparser for flow mod message +------------------------------------------ +flowModSizeInBytes' :: ActionSequence -> Int +flowModSizeInBytes' !actions = + 72 + actionSequenceSizeInBytes actions + -- 72 = headerSize + matchSize + 24 +{-# INLINE flowModSizeInBytes' #-} + +data FlowModRecordInternal = FlowModRecordInternal { + command' :: !FlowModType + , match' :: !Match + , actions' :: !([Action]) + , priority' :: !Priority + , idleTimeOut' :: !(Maybe TimeOut) + , hardTimeOut' :: !(Maybe TimeOut) + , flags' :: !([FlowModFlag]) + , bufferID' :: !(Maybe BufferID) + , outPort' :: !(Maybe PseudoPort) + , cookie' :: !Cookie + } deriving (Eq,Show) + + +-- | Specification: @ofp_flow_mod_command@. +data FlowModType + = FlowAddType + | FlowModifyType + | FlowModifyStrictType + | FlowDeleteType + | FlowDeleteStrictType + deriving (Show,Eq,Ord) + +-- | A set of flow mod attributes can be added to a flow modification command. +data FlowModFlag = SendFlowRemoved | CheckOverlap | Emergency deriving (Show,Eq,Ord,Enum) + +{-# INLINE putFlowModMain #-} +putFlowModMain :: M.TransactionID -> FlowMod -> Put +putFlowModMain !xid !fmod = + case fmod of + (DeleteFlows {..}) -> + putHeaderInternal ofptFlowMod (fromIntegral $ flowModSizeInBytes' mempty) xid <> + putMatch match <> + putWord64be 0 <> + putWord16be ofpfcDelete <> + putWord32be 0 <> + putWord16be 0 <> + putWord32be (-1) <> + (putWord16be $ maybe ofppNone fakePort2Code outPort) <> + putWord16be 0 + + (DeleteFlowStrict {..}) -> + putHeaderInternal ofptFlowMod (fromIntegral $ flowModSizeInBytes' mempty) xid <> + putMatch match <> + putWord64be 0 <> + (putWord16be $ flowModTypeToCode FlowDeleteStrictType) <> + putWord32be 0 <> + putWord16be priority <> + putWord32be (-1) <> + (putWord16be $ maybe ofppNone fakePort2Code outPort) <> + putWord16be 0 + + (AddFlow !match !priority !actions !cookie !idleTimeOut !hardTimeOut !notifyWhenRemoved !applyToPacket !overlapAllowed) -> + putHeaderInternal ofptFlowMod (fromIntegral $ flowModSizeInBytes' actions) xid <> + putMatch match <> + putWord64be cookie <> + putWord16be ofpfcAdd <> + (putWord16be $ timeOutToCode idleTimeOut) <> + (putWord16be $ timeOutToCode hardTimeOut) <> + putWord16be priority <> + (putWord32be $ maybe (-1) id applyToPacket) <> + putWord16be ofppNone <> + (putWord16be $ let overlapFlag = if overlapAllowed then 0 else 2 + removeFlag = if notifyWhenRemoved then 1 else 0 + in overlapFlag .|. removeFlag) <> + (putActions $ actionSequenceToList actions) + + (AddEmergencyFlow {..}) -> + putHeaderInternal ofptFlowMod (fromIntegral $ flowModSizeInBytes' actions) xid <> + putMatch match <> + putWord64be cookie <> + putWord16be ofpfcAdd <> + putWord32be 0 <> + putWord16be priority <> + putWord32be (-1) <> + putWord16be ofppNone <> + (putWord16be $ let emergencyFlag = 4 + overlapFlag = if overlapAllowed then 0 else 2 + in emergencyFlag .|. overlapFlag) <> + (putActions $ actionSequenceToList actions) + + (ModifyFlows {..}) -> + putHeaderInternal ofptFlowMod (fromIntegral $ flowModSizeInBytes' newActions) xid <> + putMatch match <> + putWord64be ifMissingCookie <> + (putWord16be $ flowModTypeToCode FlowModifyType) <> + (putWord16be $ timeOutToCode ifMissingIdleTimeOut) <> + (putWord16be $ timeOutToCode ifMissingHardTimeOut) <> + putWord16be ifMissingPriority <> + putWord32be (-1) <> + putWord16be ofppNone <> + (putWord16be $ let overlapFlag = if ifMissingOverlapAllowed then 0 else 2 + removeFlag = if ifMissingNotifyWhenRemoved then 1 else 0 + in overlapFlag .|. removeFlag) <> + (putActions $ actionSequenceToList newActions) + + (ModifyFlowStrict {..}) -> + putHeaderInternal ofptFlowMod (fromIntegral $ flowModSizeInBytes' newActions) xid <> + putMatch match <> + putWord64be ifMissingCookie <> + (putWord16be $ flowModTypeToCode FlowModifyStrictType) <> + (putWord16be $ timeOutToCode ifMissingIdleTimeOut) <> + (putWord16be $ timeOutToCode ifMissingHardTimeOut) <> + putWord16be priority <> + putWord32be (-1) <> + putWord16be ofppNone <> + (putWord16be $ let overlapFlag = if ifMissingOverlapAllowed then 0 else 2 + removeFlag = if ifMissingNotifyWhenRemoved then 1 else 0 + in overlapFlag .|. removeFlag) <> + (putActions $ actionSequenceToList newActions) + +(<>) :: Put -> Put -> Put +x <> y = x >> y + +mconcat :: [Put] -> Put +mconcat = sequence_ + +putActions :: [Action] -> Put +putActions = mapM_ putAction + +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 + +--fromJust2 :: String -> Maybe a -> a +--fromJust2 s Nothing = error s +--fromJust2 _ (Just a) = a + +fromJust :: Maybe a -> a +fromJust Nothing = error "MessagesBinary.fromJust" +fromJust (Just a) = a + +flowModInternal2FlowMod :: FlowModRecordInternal -> FlowMod +flowModInternal2FlowMod (FlowModRecordInternal {..}) = + case command' of + FlowDeleteType -> DeleteFlows { match = match', outPort = outPort' } + FlowDeleteStrictType -> DeleteFlowStrict { match = match', outPort = outPort', priority = priority' } + FlowAddType -> + if elem Emergency flags' + then AddEmergencyFlow { match = match' + , priority = priority' + , actions = ActionSequence (error "size unknown") actions' + , cookie = cookie' + , overlapAllowed = elem CheckOverlap flags' + } + else AddFlow { match = match' + , priority = priority' + , actions = ActionSequence (error "size unknown") actions' + , cookie = cookie' + , idleTimeOut = fromJust idleTimeOut' + , hardTimeOut = fromJust hardTimeOut' + , notifyWhenRemoved = elem SendFlowRemoved flags' + , applyToPacket = bufferID' + , overlapAllowed = elem CheckOverlap flags' + } + FlowModifyType -> ModifyFlows { match = match' + , newActions = ActionSequence (error "size unknown") actions' + , ifMissingPriority = priority' + , ifMissingCookie = cookie' + , ifMissingIdleTimeOut = fromJust idleTimeOut' + , ifMissingHardTimeOut = fromJust hardTimeOut' + , ifMissingOverlapAllowed = CheckOverlap `elem` flags' + , ifMissingNotifyWhenRemoved = SendFlowRemoved `elem` flags' + } + FlowModifyStrictType -> ModifyFlowStrict { match = match' + , newActions = ActionSequence (error "size unknown") actions' + , priority = priority' + , ifMissingCookie = cookie' + , ifMissingIdleTimeOut = fromJust idleTimeOut' + , ifMissingHardTimeOut = fromJust hardTimeOut' + , ifMissingOverlapAllowed = CheckOverlap `elem` flags' + , ifMissingNotifyWhenRemoved = SendFlowRemoved `elem` flags' + } + +timeOutToCode :: TimeOut -> Word16 +timeOutToCode Permanent = 0 +timeOutToCode (ExpireAfter t) = t + +getTimeOutFromCode :: Get (Maybe TimeOut) +getTimeOutFromCode = do code <- getWord16be + if code == 0 + then return Nothing + else return (Just (ExpireAfter code)) + +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) + + + +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) + +flowModTypeToCode :: FlowModType -> Word16 +flowModTypeToCode !FlowAddType = ofpfcAdd +flowModTypeToCode !FlowModifyType = ofpfcModify +flowModTypeToCode !FlowModifyStrictType = ofpfcModifyStrict +flowModTypeToCode !FlowDeleteType = ofpfcDelete +flowModTypeToCode !FlowDeleteStrictType = ofpfcDeleteStrict + +putAction :: Action -> Put +putAction !act = + case act of + (SendOutPort !port) -> + putWord32be 8 >> -- replaces putWord16be 0 >> putWord16be 8 + putPseudoPort port + (SetVlanVID vlanid) -> + putWord16be 1 >> + putWord16be 8 >> + putWord16be vlanid >> + putWord16be 0 + (SetVlanPriority priority) -> + putWord16be 2 >> + putWord16be 8 >> + putWord8 priority >> + putWord8 0 >> + putWord8 0 >> + putWord8 0 + (StripVlanHeader) -> + putWord16be 3 >> + putWord16be 8 >> + putWord32be 0 + (SetEthSrcAddr addr) -> + putWord16be 4 >> + putWord16be 16 >> + putEthernetAddress addr >> + sequence_ (replicate 6 (putWord8 0)) + (SetEthDstAddr addr) -> + putWord16be 5 >> + putWord16be 16 >> + putEthernetAddress addr >> + sequence_ (replicate 6 (putWord8 0)) + (SetIPSrcAddr addr) -> + putWord16be 6 >> + putWord16be 8 >> + putWord32be (ipAddressToWord32 addr) + (SetIPDstAddr addr) -> + putWord16be 7 >> + putWord16be 8 >> + putWord32be (ipAddressToWord32 addr) + (SetIPToS tos) -> + putWord16be 8 >> + putWord16be 8 >> + putWord8 tos >> + sequence_ (replicate 3 (putWord8 0)) + (SetTransportSrcPort port) -> + putWord16be 9 >> + putWord16be 8 >> + putWord16be port >> + putWord16be 0 + (SetTransportDstPort port) -> + putWord16be 10 >> + putWord16be 8 >> + putWord16be port >> + putWord16be 0 + (Enqueue port qid) -> + putWord16be 11 >> + putWord16be 16 >> + putWord16be port >> + sequence_ (replicate 6 (putWord8 0)) >> + putWord32be qid + (VendorAction vendorID 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 putWord16be 0xffff >> + putWord16be (fromIntegral l) >> + putWord32be vendorID >> + mapM_ putWord8 bytes + +putPseudoPort :: PseudoPort -> Put +putPseudoPort (PhysicalPort !pid) = + putWord16be pid >> + putWord16be 0 +putPseudoPort (ToController !maxLen) = + putWord16be ofppController >> + putWord16be maxLen +putPseudoPort !port = + putWord16be (fakePort2Code port) >> + putWord16be 0 + +actionSizeInBytes :: Action -> Int +actionSizeInBytes (!SendOutPort _) = 8 +actionSizeInBytes (!SetVlanVID _) = 8 +actionSizeInBytes (!SetVlanPriority _) = 8 +actionSizeInBytes (!StripVlanHeader) = 8 +actionSizeInBytes (!SetEthSrcAddr _) = 16 +actionSizeInBytes (!SetEthDstAddr _) = 16 +actionSizeInBytes (!SetIPSrcAddr _) = 8 +actionSizeInBytes (!SetIPDstAddr _) = 8 +actionSizeInBytes (!SetIPToS _) = 8 +actionSizeInBytes (!SetTransportSrcPort _) = 8 +actionSizeInBytes (!SetTransportDstPort _) = 8 +actionSizeInBytes (!Enqueue _ _) = 16 +actionSizeInBytes (!VendorAction _ bytes) = + let l = length bytes + 8 -- + 2 + 2 + 4 + 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 #-} + + +------------------------------------------ +-- Port mod unparser +------------------------------------------ + +portModLength :: Int +portModLength = 32 + +putPortMod :: PortMod -> Put +putPortMod (PortModRecord {..} ) = + putWord16be portNumber <> + putEthernetAddress hwAddr <> + putConfigBitMap <> + putMaskBitMap <> + putAdvertiseBitMap <> + putPad + where putConfigBitMap = putWord32be (portAttributeSet2BitMask onAttrs) + putMaskBitMap = putWord32be (portAttributeSet2BitMask attrsChanging) + 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 +statsRequestSize (PortStatsRequest _) = headerSize + 2 + 2 + 2 + 6 +statsRequestSize (DescriptionRequest) = headerSize + 2 + 2 +statsRequestSize req = error ("Size of " ++ show req ++ " not yet implemented.") + + +putStatsRequestBody :: StatsRequest -> Put +putStatsRequestBody (FlowStatsRequest match tableQuery mPort) = + putWord16be ofpstFlow >> + putWord16be 0 >> + putMatch match >> + putWord8 (tableQueryToCode tableQuery) >> + putWord8 0 >> + (putWord16be $ maybe ofppNone fakePort2Code mPort) +putStatsRequestBody (AggregateFlowStatsRequest match tableQuery mPort) = + putWord16be ofpstAggregate >> + putWord16be 0 >> + putMatch match >> + putWord8 (tableQueryToCode tableQuery) >> + putWord8 0 >> + (putWord16be $ maybe ofppNone fakePort2Code mPort) +putStatsRequestBody TableStatsRequest = + putWord16be ofpstTable >> + putWord16be 0 +putStatsRequestBody DescriptionRequest = + putWord16be ofpstDesc >> + putWord16be 0 +putStatsRequestBody (QueueStatsRequest portQuery queueQuery) = + putWord16be ofpstQueue >> + putWord16be 0 >> + putWord16be (queryToPortNumber portQuery) >> + putWord16be 0 >> + putWord32be (queryToQueueID queueQuery) +putStatsRequestBody (PortStatsRequest query) = + 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 + +-- Not yet used: ofppMax :: Word16 +-- ofppMax = 0xff00 + +ofppInPort, ofppTable, ofppNormal, ofppFlood, ofppAll, ofppController, ofppNone :: Word16 +ofppInPort = 0xfff8 +ofppTable = 0xfff9 +ofppNormal = 0xfffa +ofppFlood = 0xfffb +ofppAll = 0xfffc +ofppController = 0xfffd +-- Not yet used: ofppLocal = 0xfffe +ofppNone = 0xffff + +fakePort2Code :: PseudoPort -> Word16 +fakePort2Code Flood = ofppFlood +fakePort2Code (PhysicalPort portID) = portID +fakePort2Code InPort = ofppInPort +fakePort2Code AllPhysicalPorts = ofppAll +fakePort2Code (ToController _) = ofppController +fakePort2Code NormalSwitching = ofppNormal +fakePort2Code WithTable = ofppTable + +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 +tableQueryToCode EmergencyTable = 0xfe +tableQueryToCode (Table t) = t + +ofpstDesc, ofpstFlow, ofpstAggregate, ofpstTable, ofpstPort, ofpstQueue :: Word16 +ofpstDesc = 0 +ofpstFlow = 1 +ofpstAggregate = 2 +ofpstTable = 3 +ofpstPort = 4 +ofpstQueue = 5 +-- Not yet used: ofpstVendor = 0xffff + + + +--------------------------------------------- +-- 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 (Match inPort (MatchHeader {..}) (MatchBody {..})) = + putWord32be wildcards + >> (putWord16be $ maybe 0 id inPort) + >> (putEthernetAddress $ maybe nullEthAddr id srcEthAddress ) + >> (putEthernetAddress $ maybe nullEthAddr id dstEthAddress ) + >> (putWord16be $ maybe 0 id vLANID ) + >> (putWord8 $ maybe 0 id vLANPriority ) + >> putWord8 0 -- padding + >> (putWord16be $ maybe 0 id ethFrameType) + >> (putWord8 $ maybe 0 id ipTypeOfService ) + >> (putWord8 $ maybe 0 id matchIPProtocol ) + >> putWord16be 0 -- padding + >> (putWord32be $ ipAddressToWord32 $ addressPart srcIPAddress ) + >> (putWord32be $ ipAddressToWord32 $ addressPart dstIPAddress ) + >> (putWord16be $ maybe 0 id srcTransportPort ) + >> (putWord16be $ maybe 0 id dstTransportPort ) + where nullEthAddr = ethernetAddress64 0 + wildcards = + 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) + + + +data OFPMatch = OFPMatch { ofpm_wildcards :: !Word32, + ofpm_in_port :: !Word16, + ofpm_dl_src, ofpm_dl_dst :: !EthernetAddress, + ofpm_dl_vlan :: !Word16, + ofpm_dl_vlan_pcp :: !Word8, + ofpm_dl_type :: !Word16, + ofpm_nw_tos :: !Word8, + 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) + (MatchHeader + (getField 2 ofpm_dl_src) + (getField 3 ofpm_dl_dst) + (getField 1 ofpm_dl_vlan) + (getField 20 ofpm_dl_vlan_pcp) + (getField 4 ofpm_dl_type)) + (MatchBody + (getField 21 ofpm_nw_tos) + (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 + + +----------------------------------- +-- Utilities +----------------------------------- +getWord8s :: Int -> Get [Word8] +getWord8s n = B.unpack <$> getByteString n + +putWord8s :: [Word8] -> Put +putWord8s bytes = sequence_ [putWord8 b | b <- bytes] diff --git a/src/Network/Data/OpenFlow/Packet.hs b/src/Network/Data/OpenFlow/Packet.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/OpenFlow/Packet.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DisambiguateRecordFields, RecordWildCards #-} + +module Network.Data.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 Network.Data.OpenFlow.Port +import Network.Data.OpenFlow.Action +import Network.Data.Ethernet.EthernetFrame +import Data.Maybe (isJust, fromJust) +import Data.Word + +-- | 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 + = bufferedPacketOut (fromJust bufferID) (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 + enclosedFrame :: EthernetFrame, -- ^result of parsing packetData field. + rawBytes :: !B.ByteString + } 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 -- /= 0xffffffff + diff --git a/src/Network/Data/OpenFlow/Port.hs b/src/Network/Data/OpenFlow/Port.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/OpenFlow/Port.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Network.Data.OpenFlow.Port ( + Port (..) + , PortID + , SpanningTreePortState (..) + , PortConfigAttribute (..) + , PortFeature (..) + , PortFeatures + , PortMod (..) + , PortStatus + , PortStatusUpdateReason (..) + , portCapacity + , portAttributeOn + , portAttributeOff + , isPhysicalPort + , isPhysicalPortID + ) where + +import Data.Word +import Data.Map (Map) +import qualified Data.Map as Map +import Network.Data.Ethernet.EthernetAddress + +import Data.Aeson +import GHC.Generics + +-- ^ 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, Ord, Generic) + +instance ToJSON Port +instance FromJSON Port + +type PortID = Word16 + +data SpanningTreePortState = STPListening + | STPLearning + | STPForwarding + | STPBlocking + deriving (Show,Read,Eq,Ord,Enum, Generic) +instance ToJSON SpanningTreePortState +instance FromJSON SpanningTreePortState + +-- | 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, Generic) +instance ToJSON PortConfigAttribute +instance FromJSON PortConfigAttribute + +-- | 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, Ord, Generic) +instance ToJSON PortFeature +instance FromJSON PortFeature + +-- | Set of 'PortFeature's. Specification: bitmap of members in @enum +-- ofp_port_features@. +type PortFeatures = [PortFeature] + +-- | The max bandwidth in Mbps. +portCapacity :: Port -> Maybe Double +portCapacity port = maybe Nothing f $ portCurrentFeatures port + where + f features | elem Rate10MbHD features = Just 10 + | elem Rate10MbFD features = Just 10 + | elem Rate100MbHD features = Just 100 + | elem Rate100MbFD features = Just 100 + | elem Rate1GbHD features = Just 1000 + | elem Rate1GbFD features = Just 1000 + | elem Rate10GbFD features = Just 10000 + | otherwise = Nothing + + +-- |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 pid addr attr = PortModRecord pid addr (Map.singleton attr True) + +portAttributeOff :: PortID -> EthernetAddress -> PortConfigAttribute -> PortMod +portAttributeOff pid addr attr = PortModRecord pid addr (Map.singleton attr False) + +isPhysicalPort :: Port -> Bool +isPhysicalPort = isPhysicalPortID . portID + +isPhysicalPortID :: PortID -> Bool +isPhysicalPortID pid = pid <= 0xff00 diff --git a/src/Network/Data/OpenFlow/Statistics.hs b/src/Network/Data/OpenFlow/Statistics.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/OpenFlow/Statistics.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Network.Data.OpenFlow.Statistics ( + StatsRequest (..) + , TableQuery (..) + , PortQuery (..) + , QueueQuery (..) + , StatsReply (..) + , MoreToFollowFlag + , FlowStats (..) + , AggregateFlowStats (..) + , TableStats (..) + , PortStats (..) + , nullPortStats + , zeroPortStats + , liftIntoPortStats1 + , liftIntoPortStats2 + , Description (..) + , QueueStats (..) + ) where + +import Network.Data.OpenFlow.Port +import Network.Data.OpenFlow.Match +import Network.Data.OpenFlow.Action +import Network.Data.OpenFlow.FlowTable +import Control.Monad (liftM,liftM2) +import Data.Aeson.TH +import Data.Int + +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 + | PortStatsRequest { + portStatsQuery :: PortQuery + } + | QueueStatsRequest { queueStatsPort :: PortQuery, queueStatsQuery:: QueueQuery } + deriving (Show,Eq) + +data PortQuery = AllPorts | SinglePort PortID deriving (Show,Eq,Ord) +data QueueQuery = AllQueues | SingleQueue QueueID deriving (Show,Eq,Ord) + +data TableQuery = AllTables + | EmergencyTable + | Table FlowTableID + deriving (Show,Eq) + + + +data StatsReply + = DescriptionReply Description + | FlowStatsReply !MoreToFollowFlag [FlowStats] + | AggregateFlowStatsReply AggregateFlowStats + | TableStatsReply !MoreToFollowFlag [TableStats] + | PortStatsReply !MoreToFollowFlag [(PortID,PortStats)] + | QueueStatsReply !MoreToFollowFlag [QueueStats] + deriving (Show,Eq) + +type MoreToFollowFlag = Bool + +data Description = Description { manufacturerDesc :: String + , hardwareDesc :: String + , softwareDesc :: String + , serialNumber :: String + , datapathDesc :: String + } 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). + flowStatsCookie :: !Cookie, -- ^ Cookie associated with the flow. + flowStatsDurationSeconds :: !Int, + flowStatsDurationNanoseconds :: !Int, + flowStatsIdleTimeout :: !Int, + flowStatsHardTimeout :: !Int, + flowStatsPacketCount :: !Int64, + flowStatsByteCount :: !Int64 + } + 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) + } + + + + + +data QueueStats = QueueStats { queueStatsPortID :: PortID, + queueStatsQueueID :: QueueID, + queueStatsTransmittedBytes :: Integer, + queueStatsTransmittedPackets :: Integer, + queueStatsTransmittedErrors :: Integer } deriving (Show,Eq) + +$(deriveJSON defaultOptions ''PortStats) + diff --git a/src/Network/Data/OpenFlow/Switch.hs b/src/Network/Data/OpenFlow/Switch.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/OpenFlow/Switch.hs @@ -0,0 +1,70 @@ +module Network.Data.OpenFlow.Switch ( + SwitchFeatures (..) + , SwitchID + , SwitchCapability (..) + , maxNumberPorts + , QueueConfigRequest (..) + , QueueConfigReply (..) + , QueueConfig (..) + , QueueLength + , QueueProperty (..) + , QueueRate (..) + , showSwID + ) where + +import Data.Word +import Network.Data.OpenFlow.Port +import Network.Data.OpenFlow.Action +import Numeric (showHex) + +-- |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 + +showSwID :: SwitchID -> String +showSwID sid = "0x" ++ showHex sid "" + +-- | Maximum number of ports on a switch +maxNumberPorts :: PortID +maxNumberPorts = 0xff00 + + +-- |The switch capabilities are denoted with these symbols +data SwitchCapability = HasFlowStats -- ^can provide flow statistics + | HasTableStats -- ^can provide table statistics + | HasPortStats -- ^can provide port statistics + | SpanningTree -- ^supports the 802.1d spanning tree protocol + | MayTransmitOverMultiplePhysicalInterfaces + | HasQueueStatistics -- ^can provide queue statistics + | CanMatchIPAddressesInARPPackets -- ^match IP addresses in ARP packets + | CanReassembleIPFragments -- ^can reassemble IP fragments + deriving (Show,Read,Eq,Ord,Enum) + + +data QueueConfigRequest = QueueConfigRequest PortID + deriving (Show,Read,Eq) + +data QueueConfigReply = PortQueueConfig PortID [QueueConfig] + deriving (Show,Read,Eq) + +data QueueConfig = QueueConfig QueueID [QueueProperty] + deriving (Show,Read,Eq) + +type QueueLength = Word16 + +data QueueProperty = MinRateQueue QueueRate + deriving (Show,Read,Eq) +data QueueRate = Disabled | Enabled Word16 + deriving (Show, Read, Eq) + + diff --git a/src/Network/Data/Util.hs b/src/Network/Data/Util.hs new file mode 100644 --- /dev/null +++ b/src/Network/Data/Util.hs @@ -0,0 +1,19 @@ +module Network.Data.Util + ( + concatIntersperse + , unConcatIntersperse + ) where + +import Data.List (intersperse) + +-- Specifications: +-- (A) unConcatIntersperse c . concatIntersperse [c] == id + +concatIntersperse :: [a] -> [[a]] -> [a] +concatIntersperse xs = concat . intersperse xs + +unConcatIntersperse :: Eq a => a -> [a] -> [[a]] +unConcatIntersperse c s = + let (r,t) = break (==c) s + in r : case t of { [] -> []; _:t' -> unConcatIntersperse c t' } +