{-# 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
