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