{-# LANGUAGE RecordWildCards #-}

{- | [Haskell OpenFlow]

This is an implementation of OpenFlow in Haskell.

-}
module Network.OpenFlow (
    OfpFrame(..)
  , OfpHeader(..)
  , OfpMsg(..)
  , OfpError(..)
  , OfpHelloFailedCode(..)
  , OfpBadRequestCode(..)
  , OfpBadActionCode(..)
  , OfpFlowModFailedCode(..)
  , OfpPortModFailedCode(..)
  , OfpQueueOpFailedCode(..)
  , OfpSwitchFeatures(..)
  , OfpPhyPort(..)
  , OfpCapabilities(..)
  , OfpActionType(..)
  , OfpPortConfig(..)
  , OfpPortState(..)
  , OfpPortFeatures(..)
  , OfpSwitchConfig(..)
  , OfpConfigFlags(..)
  , OfpFlowMod(..)
  , OfpMatch(..)
  , OfpFlowModCommand(..)
  , OfpFlowModFlags(..)
  , OfpAction(..)
  , OfpFlowWildcards(..)
  , OfpPacketIn(..)
  , OfpPacketInReason(..)
  , OfpPacketOut(..)
  , OfpFlowRemoved(..)
  , OfpFlowRemovedReason(..)
  , OfpPortStatus(..)
  , OfpPortReason(..)
  , OfpPortMod(..)
  , OfpQueueGetConfigRequest(..)
  , OfpQueueGetConfigReply(..)
  , OfpPacketQueue(..)
  , OfpQueueProp(..)
  , readOfpFrame
  ) where

import GHC.Word
import Control.Monad
import Data.Functor
import Data.Bits
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C
import Data.Serialize
import Data.Serialize.Get
import Data.Serialize.Put
import Network.Socket hiding (recv)
import Network.Socket.ByteString
import Network.Info


data OfpFrame =
  -- 5.1 Each OpenFlow message begins with the OpenFlow header
  OfpFrame { hdr :: OfpHeader
           , msg :: OfpMsg
           } deriving (Show)

instance Serialize OfpFrame where
  put (OfpFrame (OfpHeader version _ _ xid) msg) = do
    putWord8 version
    putWord8 $ msgType msg
    let bs = runPut $ putOfpMsg msg
    let len = ofpHdrLen + (BS.length bs)
    put ((fromIntegral len) :: Word16)
    putWord32be xid
    putByteString bs
  get = do
    hdr <- get :: Get OfpHeader
    msg <- getOfpMsg hdr
    return $ OfpFrame hdr msg

data OfpHeader =
  OfpHeader { version :: Word8
            , ty      :: Word8
            , len     :: Word16
            , xid     :: Word32
            } deriving (Show)

ofpHdrLen = 8

instance Serialize OfpHeader where
  put (OfpHeader {..}) = do
    putWord8 version
    putWord8 ty
    putWord16be len
    putWord32be xid
  get = do
    version <- liftM fromIntegral getWord8
    ty      <- liftM fromIntegral getWord8
    len     <- liftM fromIntegral getWord16be
    xid     <- liftM fromIntegral getWord32be
    return $ OfpHeader version ty len xid

data OfpMsg = OfptHello [Word8]
            | OfptError OfpError
            | OfptEchoRequest [Word8]
            | OfptEchoReply [Word8]
            | OfptVendor
            | OfptFeaturesRequest
            | OfptFeaturesReply OfpSwitchFeatures
            | OfptGetConfigRequest
            | OfptGetConfigReply OfpSwitchConfig
            | OfptSetConfig OfpSwitchConfig
            | OfptPacketIn OfpPacketIn
            | OfptFlowRemoved OfpFlowRemoved
            | OfptPortStatus OfpPortStatus
            | OfptPacketOut OfpPacketOut
            | OfptFlowMod OfpFlowMod
            | OfptPortMod OfpPortMod
            | OfptBarrierRequest
            | OfptBarrierReply
            | OfptQueueGetConfigRequest OfpQueueGetConfigRequest
            | OfptQueueGetConfigReply OfpQueueGetConfigReply
            deriving (Show)

-- | Immutable messages
msgType (OfptHello _)                 = 0
msgType (OfptError _)                 = 1
msgType (OfptEchoRequest _)           = 2
msgType (OfptEchoReply _)             = 3
msgType (OfptVendor)                  = 4
-- | Switch configuration messages
msgType (OfptFeaturesRequest)         = 5
msgType (OfptFeaturesReply _)         = 6
msgType (OfptGetConfigRequest)        = 7
msgType (OfptGetConfigReply _)        = 8
msgType (OfptSetConfig _)             = 9
-- | Asynchronous messages
msgType (OfptPacketIn _)              = 10
msgType (OfptFlowRemoved _)           = 11
msgType (OfptPortStatus _)            = 12
-- | Controller command messages
msgType (OfptPacketOut _)             = 13
msgType (OfptFlowMod _)               = 14
msgType (OfptPortMod _)               = 15
-- | Statistics messages
--msgType (OfptStatsRequest)       = 16
--msgType (OfptStatsReply)         = 17
-- | Barrier messages
msgType (OfptBarrierRequest)          = 18
msgType (OfptBarrierReply)            = 19
-- | Queue configuration messages
msgType (OfptQueueGetConfigRequest _) = 20
msgType (OfptQueueGetConfigReply _)   = 21

data OfpError = OfpetHelloFailed OfpHelloFailedCode String
              | OfpetBadRequest OfpBadRequestCode
              | OfpetBadAction OfpBadActionCode
              | OfpetFlowModFailed OfpFlowModFailedCode
              | OfpetPortModFailed OfpPortModFailedCode
              | OfpetQueueOpFailed OfpQueueOpFailedCode
              deriving (Show)

data OfpHelloFailedCode = OfphfcIncompatible
                        | OfphfcEperm
                        deriving (Show, Enum)

data OfpBadRequestCode = OfpbrcBadVersion
                       | OfpbrcBadType
                       | OfpbrcBadStat
                       | OfpbrcBadVendor
                       | OfpbrcBadSubtype
                       | OfpbrcEperm
                       | OfpbrcBadLen
                       | OfpbrcBufferEmpty
                       | OfpbrcBufferUnknown
                       deriving (Show, Enum)

data OfpBadActionCode = OfpbacBadType
                      | OfpbacBadLen
                      | OfpbacBadVendor
                      | OfpbacBadVendorType
                      | OfpbacBadOutPort
                      | OfpbacBadArgument
                      | OfpbacEperm
                      | OfpbacTooMany
                      | OfpbacBadQueue
                      deriving (Show, Enum)

data OfpFlowModFailedCode = OfpfmfcAllTablesFull
                          | OfpfmfcOverlap
                          | OfpfmfcEperm
                          | OfpfmfcBadEmergTimeout
                          | OfpfmfcBadCommand
                          | OfpfmfcUnsupported
                          deriving (Show, Enum)

data OfpPortModFailedCode = OfppmfcBadPort
                          | OfppmfcBadHwAddr
                          deriving (Show, Enum)

data OfpQueueOpFailedCode = OfpqofcBadPort
                          | OfpqofcBadQueue
                          | OfpqofcEperm
                          deriving (Show, Enum)

data OfpSwitchFeatures =
  OfpSwitchFeatures { dataPathId   :: Word64
                    , nBuffers     :: Word32
                    , nTables      :: Word8
                    , capabilities :: [OfpCapabilities]
                    , actions      :: [OfpActionType]
                    , ports        :: [OfpPhyPort]
                    } deriving (Show)

data OfpCapabilities = OfpcFlowStats
                     | OfpcTableStats
                     | OfpcPortStats
                     | OfpcStp
                     | OfpcReserved
                     | OfpcIpReasm
                     | OfpcQueueStats
                     | OfpcArpMatchIp
                     deriving (Show, Enum)

data OfpActionType = OfpatOutput
                   | OfpatSetVlanVid
                   | OfpatSetVlanPcp
                   | OfpatStripVlan
                   | OfpatSetDlSrc
                   | OfpatSetDlDst
                   | OfpatSetNwSrc
                   | OfpatSetNwDst
                   | OfpatSetNwTos
                   | OfpatSetTpSrc
                   | OfpatSetTpDst
                   | OfpatEnqueue
                   | OfpatVendor
                   deriving (Show, Enum)

data OfpPhyPort =
  OfpPhyPort { portNo :: Word16
             , hwAddr :: MAC
             , name   :: String
             , config :: [OfpPortConfig]
             , state  :: [OfpPortState]
             , curr       :: [OfpPortFeatures]
             , advertised :: [OfpPortFeatures]
             , supported  :: [OfpPortFeatures]
             , peer       :: [OfpPortFeatures]
             } deriving (Show)

instance Serialize MAC where
  put (MAC w1 w2 w3 w4 w5 w6) = do
    putWord8 w1
    putWord8 w2
    putWord8 w3
    putWord8 w4
    putWord8 w5
    putWord8 w6
  get = do
    w1 <- liftM fromIntegral getWord8
    w2 <- liftM fromIntegral getWord8
    w3 <- liftM fromIntegral getWord8
    w4 <- liftM fromIntegral getWord8
    w5 <- liftM fromIntegral getWord8
    w6 <- liftM fromIntegral getWord8
    return $ MAC w1 w2 w3 w4 w5 w6

ofpMaxPortNameLen = 16

prependSpace xs 0 = xs
prependSpace xs n = prependSpace (" " ++ xs) (n-1)

instance Serialize OfpPhyPort where
  put (OfpPhyPort {..}) = do
    putWord16be portNo
    put hwAddr
    putByteString $ C.pack $ prependSpace name (ofpMaxPortNameLen - (length name))
    putWord32be $ enumToBitInst config
    putWord32be $ enumToBitInst state
    putWord32be $ enumToBitInst curr
    putWord32be $ enumToBitInst advertised
    putWord32be $ enumToBitInst supported
    putWord32be $ enumToBitInst peer
  get = do
    portNo <- liftM fromIntegral getWord16be
    hwAddr <- get :: Get MAC
    nameBS <- getByteString ofpMaxPortNameLen
    let name = C.unpack nameBS
    configBits     <- getWord32be
    stateBits      <- getWord32be
    currBits       <- getWord32be
    advertisedBits <- getWord32be
    supportedBits  <- getWord32be
    peerBits       <- getWord32be
    let config     = word32ToEnum configBits
    let state      = word32ToEnum stateBits
    let curr       = word32ToEnum currBits
    let advertised = word32ToEnum advertisedBits
    let supported  = word32ToEnum supportedBits
    let peer       = word32ToEnum peerBits
    return $ OfpPhyPort portNo hwAddr name config state curr advertised supported peer

data OfpPortConfig = OfppcPortDown
                   | OfppcNoStp
                   | OfppcNoRecv
                   | OfppcNoRecvStp
                   | OfppcNoFlood
                   | OfppcNoFwd
                   | OfppcNoPacketIn
                   deriving (Show, Enum)

data OfpPortState = OfppsLinkDown
                  | OfppsStpListen
                  | OfppsStpLearn
                  | OfppsStpForward
                  | OfppsStpBlock
                  | OfppsStpMask
                  deriving (Show, Enum)

data OfpPortFeatures = Ofppf10MbHd
                     | Ofppf10MbFd
                     | Ofppf100MbHd
                     | Ofppf100MbFd
                     | Ofppf1GbHd
                     | Ofppf1GbFd
                     | Ofppf10GbFd
                     | OfppfCopper
                     | OfppfFiber
                     | OfppfAutoneg
                     | OfppfPause
                     | OfppfPauseAsym
                     deriving (Show, Enum)

data OfpSwitchConfig =
  OfpSwitchConfig { flags       :: [OfpConfigFlags]
                  , missSendLen :: Word16
                  } deriving (Show)

instance Serialize OfpSwitchConfig where
  put (OfpSwitchConfig {..}) = do
    putWord16be $ enumToBitInst flags
    putWord16be missSendLen
  get = do
    flagsBits <- getWord16be
    let flags = word16ToEnum flagsBits
    missSendLen <- getWord16be
    return $ OfpSwitchConfig flags missSendLen  

data OfpConfigFlags = OfpcFragNormal
                    | OfpcFragDrop
                    | OfpcFragReasm
                    | OfpcFragMask
                    deriving (Show, Enum)

data OfpFlowMod =
  OfpFlowMod { match       :: OfpMatch
             , cookie      :: Word64
             , command     :: OfpFlowModCommand
             , idleTimeout :: Word16
             , hardTimeout :: Word16
             , priority    :: Word16
             , bufferId    :: Word32
             , outPort     :: Word16
             , fmFlags     :: OfpFlowModFlags
             , fmActions   :: [OfpAction]
             } deriving (Show)               

instance Serialize OfpFlowMod where
  put (OfpFlowMod {..}) = do
    put match
    putWord64be cookie
    putWord16be $ fromIntegral $ fromEnum command
    putWord16be idleTimeout
    putWord16be hardTimeout
    putWord16be priority
    putWord32be bufferId
    putWord16be outPort
    putWord16be $ fromIntegral $ fromEnum fmFlags
    mapM_ put fmActions
  get = do
    match       <- get :: Get OfpMatch
    cookie      <- getWord64be
    command'    <- liftM fromIntegral getWord16be
    let command = toEnum command' :: OfpFlowModCommand
    idleTimeout <- getWord16be
    hardTimeout <- getWord16be
    priority    <- getWord16be
    bufferId    <- getWord32be
    outPort     <- getWord16be
    flags'      <- liftM fromIntegral getWord16be
    let flags = toEnum flags' :: OfpFlowModFlags
    rem <- remaining
    actionsBS   <- getByteString rem
    let actions = readMany actionsBS
    return $ OfpFlowMod match cookie command idleTimeout hardTimeout priority bufferId outPort flags actions

data OfpAction = OfpOutput     Word16 Word16
               | OfpSetVlanVid Word16
               | OfpSetVlanPcp Word8
               | OfpStripVlan
               | OfpSetDlSrc   MAC
               | OfpSetDlDst   MAC
               | OfpSetNwSrc   Word32
               | OfpSetNwDst   Word32
               | OfpSetNwTos   Word8
               | OfpSetTpSrc   Word16
               | OfpSetTpDst   Word16
               | OfpEnqueue    Word16 Word32
               | OfpVendor
               deriving (Show)

instance Serialize OfpAction where
  put (OfpOutput port maxLen) = do
    putWord16be 0
    putWord16be 8
    putWord16be port
    putWord16be maxLen
  put (OfpSetVlanVid vlanVid) = do
    putWord16be 1
    putWord16be 8
    putWord16be vlanVid
    putWord16be 0 -- pad
  put (OfpSetVlanPcp vlanPcp) = do
    putWord16be 2
    putWord16be 8
    putWord8 vlanPcp
    putWord8 0 -- pad
    putWord8 0 -- pad
    putWord8 0 -- pad
  put (OfpStripVlan) = do
    putWord16be 3
    putWord16be 8
    putWord32be 0 -- pad
  put (OfpSetDlSrc mac) = do
    putWord16be 4
    putWord16be 16
    put mac
    putWord16be 0 -- pad
    putWord16be 0 -- pad
    putWord16be 0 -- pad
  put (OfpSetDlDst mac) = do
    putWord16be 5
    putWord16be 16
    put mac
    putWord16be 0 -- pad
    putWord16be 0 -- pad
    putWord16be 0 -- pad
  put (OfpSetNwSrc nwAddr) = do
    putWord16be 6
    putWord16be 8
    putWord32be nwAddr
  put (OfpSetNwDst nwAddr) = do
    putWord16be 7
    putWord16be 8
    putWord32be nwAddr
  put (OfpSetNwTos nwTos) = do
    putWord16be 8
    putWord16be 8
    putWord8 nwTos
    putWord8 0 -- pad
    putWord8 0 -- pad
    putWord8 0 -- pad
  put (OfpSetTpSrc tpPort) = do
    putWord16be 9
    putWord16be 8
    putWord16be tpPort
    putWord16be 0 -- pad
  put (OfpSetTpDst tpPort) = do
    putWord16be 10
    putWord16be 8
    putWord16be tpPort
    putWord16be 0 -- pad
  put (OfpEnqueue port queueId) = do
    putWord16be 11
    putWord16be 16
    putWord16be port
    putWord16be 0 -- pad
    putWord32be 0 -- pad
    putWord32be queueId
  put (OfpVendor) = do
    putWord16be 0xffff
    putWord16be 8
    putWord32be 0 -- pad
  get = do
    ty  <- getWord16be
    len <- getWord16be
    case ty of
      0 -> do
        port   <- getWord16be
        maxLen <- getWord16be
        return $ OfpOutput port maxLen
      1 -> do
        vlanVid <- getWord16be
        pad1    <- getWord16be
        return $ OfpSetVlanVid vlanVid
      2 -> do
        vlanPcp <- getWord8
        pad1 <- getWord8
        pad2 <- getWord8
        pad3 <- getWord8
        return $ OfpSetVlanPcp vlanPcp
      3 -> do
        pad1 <- getWord32be
        return $ OfpStripVlan
      4 -> do
        mac <- get :: Get MAC
        pad1 <- getWord16be
        pad2 <- getWord16be
        pad3 <- getWord16be
        return $ OfpSetDlSrc mac
      5 -> do
        mac <- get :: Get MAC
        pad1 <- getWord16be
        pad2 <- getWord16be
        pad3 <- getWord16be
        return $ OfpSetDlDst mac
      6 -> do
        nwAddr <- getWord32be
        return $ OfpSetNwSrc nwAddr
      7 -> do
        nwAddr <- getWord32be
        return $ OfpSetNwDst nwAddr
      8 -> do
        nwTos <- getWord8
        pad1 <- getWord8
        pad2 <- getWord8
        pad2 <- getWord8
        return $ OfpSetNwTos nwTos
      9 -> do
        tpPort <- getWord16be
        pad1 <- getWord16be
        return $ OfpSetTpSrc tpPort
      10 -> do
        tpPort <- getWord16be
        pad1 <- getWord16be
        return $ OfpSetTpDst tpPort
      11 -> do
        port <- getWord16be
        pad1 <- getWord16be
        pad2 <- getWord32be
        queueId <- getWord32be
        return $ OfpEnqueue port queueId
      0xffff -> return OfpVendor


data OfpMatch =
  OfpMatch { wildcards :: [OfpFlowWildcards]
           , inPort    :: Word16
           , dlSrc     :: MAC
           , dlDst     :: MAC
           , dlVlan    :: Word16
           , dlVlanPcp :: Word8
           , dlType    :: Word16
           , nwTos     :: Word8
           , nwProto   :: Word8
           , nwSrc     :: Word32
           , nwDst     :: Word32
           , tpSrc     :: Word16
           , tpDst     :: Word16
           } deriving (Show)

instance Serialize OfpMatch where
  put (OfpMatch {..}) = do
    putWord32be $ enumToBitInst wildcards
    putWord16be inPort
    put dlSrc
    put dlDst
    putWord16be dlVlan
    putWord8    dlVlanPcp
    putWord8 0
    putWord16be dlType
    putWord8    nwTos
    putWord8    nwProto
    putWord8 0
    putWord8 0
    putWord32be nwSrc
    putWord32be nwDst
    putWord16be tpSrc
    putWord16be tpDst
  get = do
    wildcardBits <- getWord32be
    let wildcards = word32ToEnum wildcardBits
    inPort       <- getWord16be
    dlSrc <- get :: Get MAC
    dlDst <- get :: Get MAC
    dlVlan    <- getWord16be
    dlVlanPcp <- getWord8
    pad1      <- getWord8
    dlType    <- getWord16be
    nwTos     <- getWord8
    nwProto   <- getWord8
    pad2      <- getWord8
    pad3      <- getWord8
    nwSrc     <- getWord32be
    nwDst     <- getWord32be
    tpSrc     <- getWord16be
    tpDst     <- getWord16be
    return $ OfpMatch wildcards inPort dlSrc dlDst dlVlan dlVlanPcp dlType nwTos nwProto nwSrc nwDst tpSrc tpDst

data OfpFlowWildcards = OfpfwInPort
                      | OfpfwDlVlan
                      | OfpfwDlSrc
                      | OfpfwDlDst
                      | OfpfwDlType
                      | OfpfwNwProto
                      | OfpfwTpSrc
                      | OfpfwTpDst
                      | OfpfwNwSrc -- incomplete! 6 bits
                      | OfpfwNwDst -- incomplete! 6 bits
                      | OfpfwDlVlanPcp
                      | OfpfwNwTos
                      | OfpfwAll
                      deriving (Show)

instance Enum OfpFlowWildcards where
  fromEnum (OfpfwInPort)    = 0
  fromEnum (OfpfwDlVlan)    = 1
  fromEnum (OfpfwDlSrc)     = 2
  fromEnum (OfpfwDlDst)     = 3
  fromEnum (OfpfwDlType)    = 4
  fromEnum (OfpfwNwProto)   = 5
  fromEnum (OfpfwTpSrc)     = 6
  fromEnum (OfpfwTpDst)     = 7
  fromEnum (OfpfwNwSrc)     = 8
  fromEnum (OfpfwNwDst)     = 14
  fromEnum (OfpfwDlVlanPcp) = 20
  fromEnum (OfpfwNwTos)     = 21
  fromEnum (OfpfwAll)       = 22
  toEnum 0  = (OfpfwInPort)
  toEnum 1  = (OfpfwDlVlan)
  toEnum 2  = (OfpfwDlSrc)
  toEnum 3  = (OfpfwDlDst)
  toEnum 4  = (OfpfwDlType)
  toEnum 5  = (OfpfwNwProto)
  toEnum 6  = (OfpfwTpSrc)
  toEnum 7  = (OfpfwTpDst)
  toEnum 8  = (OfpfwNwSrc)
  toEnum 14 = (OfpfwNwDst)
  toEnum 20 = (OfpfwDlVlanPcp)
  toEnum 21 = (OfpfwNwTos)
  toEnum 22 = (OfpfwAll)

allWildcards = [ OfpfwInPort, OfpfwDlVlan, OfpfwDlSrc,
                 OfpfwDlDst, OfpfwDlType, OfpfwNwProto,
                 OfpfwTpSrc, OfpfwTpDst, OfpfwNwSrc, OfpfwNwDst,
                 OfpfwDlVlanPcp, OfpfwNwTos, OfpfwAll ]

data OfpFlowModCommand = OfpfcAdd
                       | OfpfcModify
                       | OfpfcModifyStrict
                       | OfpfcDelete
                       | OfpfcDeleteStrict
                       deriving (Show, Enum)

data OfpFlowModFlags = OfpffSendFlowRem
                     | OfpffCheckOverlap
                     | OfpffEmerg
                     deriving (Show, Enum)

data OfpPacketIn =
  OfpPacketIn { piBufferId :: Word32
              , totalLen   :: Word16
              , piInPort   :: Word16
              , reason     :: OfpPacketInReason
              , dat        :: [Word8]
              } deriving (Show)

instance Serialize OfpPacketIn where
  put (OfpPacketIn {..}) = do
    let dat' = BS.pack dat
    let len  = BS.length dat'
    putWord32be piBufferId
    put ((fromIntegral len) :: Word16)
    putWord16be piInPort
    putWord8 $ fromIntegral $ fromEnum reason
    putWord8 0 -- pad
    putByteString dat'
  get = do
    bufferId <- getWord32be
    totalLen <- getWord16be
    inPort   <- getWord16be
    reason'  <- liftM fromIntegral getWord8
    let reason = toEnum reason' :: OfpPacketInReason
    pad0 <- getWord8
    rem  <- remaining
    -- assert(rem == totalLen)
    dat' <- getByteString rem
    let dat = BS.unpack dat'
    return $ OfpPacketIn bufferId totalLen inPort reason dat

data OfpPacketInReason = OfprNoMatch
                       | OfprAction
                       deriving (Show, Enum)

data OfpPacketOut =
  OfpPacketOut { poBufferId :: Word32
               , poInPort   :: Word16
               , poActions  :: [OfpAction]
               , poDat      :: [Word8]
               } deriving (Show)

instance Serialize OfpPacketOut where
  put (OfpPacketOut {..}) = do
    putWord32be poBufferId
    putWord16be poInPort
    let actions' = runPut (mapM_ put poActions)
    let len = BS.length actions'
    put ((fromIntegral len) :: Word16)
    putByteString actions'
    putByteString $ BS.pack poDat
  get = do
    bufferId   <- getWord32be
    inPort     <- getWord16be
    actionsLen <- getWord16be
    actionsBS  <- getByteString (fromIntegral actionsLen)
    let actions = readMany actionsBS
    rem  <- remaining
    dat' <- getByteString rem
    let dat = BS.unpack dat'
    return $ OfpPacketOut bufferId inPort actions dat

data OfpFlowRemoved =
  OfpFlowRemoved { frMatch       :: OfpMatch
                 , frCookie      :: Word64
                 , frPriority    :: Word16
                 , frReason      :: OfpFlowRemovedReason
                 , durationSec   :: Word32
                 , durationNSec  :: Word32
                 , frIdleTimeout :: Word16
                 , packetCount   :: Word64
                 , byteCount     :: Word64
                 } deriving (Show)

instance Serialize OfpFlowRemoved where
  put (OfpFlowRemoved match cookie pri reason sec nsec idleTO pCnt bCnt) = do
    put match
    putWord64be cookie
    putWord16be pri
    putWord8 $ fromIntegral $ fromEnum reason
    putWord32be sec
    putWord32be nsec
    putWord16be idleTO
    putWord64be pCnt
    putWord64be bCnt
  get = do
    match   <- get :: Get OfpMatch    
    cookie  <- getWord64be
    pri     <- getWord16be
    reason' <- liftM fromIntegral getWord8
    let reason = toEnum reason' :: OfpFlowRemovedReason
    sec     <- getWord32be
    nsec    <- getWord32be
    idleTO  <- getWord16be
    pCnt    <- getWord64be
    bCnt    <- getWord64be
    return $ OfpFlowRemoved match cookie pri reason sec nsec idleTO pCnt bCnt

data OfpFlowRemovedReason = OfprrIdleTimeout
                          | OfprrHardTimeout
                          | OfprrDelete
                          deriving (Show, Enum)

data OfpPortStatus =
  OfpPortStatus { psReason :: OfpPortReason
                , desc     :: OfpPhyPort
                } deriving (Show)

instance Serialize OfpPortStatus where
  put (OfpPortStatus reason desc) = do
    putWord8 $ fromIntegral $ fromEnum reason
    putWord32be 0 -- pad
    putWord16be 0 -- pad
    putWord8 0    -- pad
    put desc
  get = do
    reason' <- liftM fromIntegral getWord8
    let reason = toEnum reason' :: OfpPortReason
    pad1 <- getWord32be
    pad2 <- getWord16be
    pad3 <- getWord8
    desc <- get :: Get OfpPhyPort
    return $ OfpPortStatus reason desc

data OfpPortReason = OfpprAdd
                   | OfpprDelete
                   | OfpprModify
                   deriving (Show, Enum)

data OfpPortMod =
  OfpPortMod { pmPortNo    :: Word16
             , pmHwAddr    :: MAC
             , pmConfig    :: [OfpPortConfig]
             , pmMask      :: [OfpPortConfig]
             , pmAdvertise :: [OfpPortFeatures]
             } deriving (Show)

instance Serialize OfpPortMod where
  put (OfpPortMod portNo hwAddr config mask adv) = do
    putWord16be portNo
    put hwAddr
    putWord32be $ enumToBitInst config
    putWord32be $ enumToBitInst mask
    putWord32be $ enumToBitInst adv
    putWord32be 0 -- pad
  get = do
    portNo  <- getWord16be
    hwAddr  <- get :: Get MAC
    config' <- getWord32be
    mask'   <- getWord32be
    adv'    <- getWord32be
    pad     <- getWord32be
    let config = word32ToEnum config'
    let mask   = word32ToEnum mask'
    let adv    = word32ToEnum adv'
    return $ OfpPortMod portNo hwAddr config mask adv

data OfpQueueGetConfigRequest =
  OfpQueueGetConfigRequest { qreqPort :: Word16
                           } deriving (Show)

instance Serialize OfpQueueGetConfigRequest where
  put (OfpQueueGetConfigRequest port) = do
    putWord16be port
    putWord16be 0 -- pad
  get = do
    port <- getWord16be
    pad  <- getWord16be
    return $ OfpQueueGetConfigRequest port

data OfpQueueGetConfigReply =
  OfpQueueGetConfigReply { qrepPort :: Word16
                         , queues   :: [OfpPacketQueue]
                         } deriving (Show)

instance Serialize OfpQueueGetConfigReply where
  put (OfpQueueGetConfigReply port queues) = do
    putWord16be port
    putWord32be 0 -- pad
    putWord16be 0 -- pad
    mapM_ put queues
  get = do
    port <- getWord16be
    pad1 <- getWord32be
    pad2 <- getWord16be
    rem  <- remaining
    queuesBS <- getByteString rem
    let queues = readMany queuesBS
    return $ OfpQueueGetConfigReply port queues

data OfpPacketQueue =
  OfpPacketQueue { pqQueueId  :: Word32
                 , properties :: [OfpQueueProp]
                 } deriving (Show)

instance Serialize OfpPacketQueue where
  put (OfpPacketQueue qid props) = do
    putWord32be qid
    let props' = runPut (mapM_ put props)
    let len = BS.length props'
    put ((fromIntegral len) :: Word16)
    putWord16be 0 -- pad
    putByteString props'
  get = do
    qid <- getWord32be
    len <- getWord16be
    pad <- getWord16be
    propsBS <- getByteString (fromIntegral len)
    let props = readMany propsBS
    return $ OfpPacketQueue qid props

data OfpQueueProp = OfpqtNone
                  | OfpqtMinRate Word16
                  deriving (Show)

instance Serialize OfpQueueProp where
  put (OfpqtNone) = do
    putWord16be 0
    putWord16be 8
    putWord32be 0 -- pad
  put (OfpqtMinRate rate) = do
    putWord16be 1
    putWord16be 16
    putWord32be 0 -- pad
    putWord16be rate
    putWord32be 0 -- pad
    putWord16be 0 -- pad
  get = do
    property <- getWord16be
    len      <- getWord16be
    pad1     <- getWord32be
    case property of
      0 -> return OfpqtNone
      1 -> do
        rate <- getWord16be
        pad2 <- getWord32be
        pad3 <- getWord16be
        return $ OfpqtMinRate rate


putOfpErrorMsg ty code = do
  putWord16be ty
  putWord16be $ fromIntegral $ fromEnum code

enumToBitInst :: (Enum a, Bits b, Num b) => [a] -> b
enumToBitInst xs = f xs 0
  where
    f xs' w = foldl (\ w x -> w `setBit` fromEnum x) w xs

putOfpMsg :: OfpMsg -> Put
putOfpMsg (OfptHello msg) = putByteString $ BS.pack msg
putOfpMsg (OfptError (OfpetHelloFailed code msg)) = do
  putOfpErrorMsg 0 code
  putByteString $ C.pack msg
putOfpMsg (OfptError (OfpetBadRequest code))    = putOfpErrorMsg 1 code
putOfpMsg (OfptError (OfpetBadAction code))     = putOfpErrorMsg 2 code
putOfpMsg (OfptError (OfpetFlowModFailed code)) = putOfpErrorMsg 3 code
putOfpMsg (OfptError (OfpetPortModFailed code)) = putOfpErrorMsg 4 code
putOfpMsg (OfptError (OfpetQueueOpFailed code)) = putOfpErrorMsg 5 code
putOfpMsg (OfptEchoRequest dat) = putByteString $ BS.pack dat
putOfpMsg (OfptEchoReply dat)   = putByteString $ BS.pack dat
putOfpMsg (OfptVendor)          = putByteString BS.empty
putOfpMsg (OfptFeaturesRequest) = putByteString BS.empty
putOfpMsg (OfptFeaturesReply (OfpSwitchFeatures dip nbuf ntab caps actions ports)) = do
  putWord64be dip
  putWord32be nbuf
  putWord8 ntab
  putWord8 0 -- pad
  putWord8 0 -- pad
  putWord8 0 -- pad
  putWord32be $ enumToBitInst caps
  putWord32be $ enumToBitInst actions
  mapM_ put ports
putOfpMsg (OfptGetConfigRequest)            = putByteString BS.empty
putOfpMsg (OfptGetConfigReply switchConfig) = put switchConfig
putOfpMsg (OfptSetConfig switchConfig)      = put switchConfig
putOfpMsg (OfptPacketIn packetIn)           = put packetIn
putOfpMsg (OfptFlowRemoved flowRemoved)     = put flowRemoved
putOfpMsg (OfptPortStatus portStatus)       = put portStatus
putOfpMsg (OfptPacketOut packetOut)         = put packetOut
putOfpMsg (OfptFlowMod flowMod)             = put flowMod
putOfpMsg (OfptPortMod portMod)             = put portMod
putOfpMsg (OfptBarrierRequest)              = putByteString BS.empty
putOfpMsg (OfptBarrierReply)                = putByteString BS.empty
putOfpMsg (OfptQueueGetConfigRequest qreq)  = put qreq
putOfpMsg (OfptQueueGetConfigReply qrep)    = put qrep
        
readMany :: (Serialize t) => BS.ByteString -> [t]
readMany bs = case runGet (readMany' [] 0) bs of
  Left err -> error err
  Right t  -> t
  where
    readMany _ 1000 = error "readMany overflow"
    readMany' l n = do
      x   <- get
      rem <- remaining
      if rem > 0
        then readMany' (x:l) (n+1)
        else return (x:l)

bitInstToEnum :: (Enum a, Bits b) => b -> Int -> [a]
bitInstToEnum w width = f 0 []
  where
    f i xs = if i == width
               then xs
               else f (i+1) xs ++ [toEnum i | w `testBit` i]

word16ToEnum word = bitInstToEnum word 16
word32ToEnum word = bitInstToEnum word 32
word64ToEnum word = bitInstToEnum word 64


getOfpMsg (OfpHeader _ ty len _) = 
  case ty of
    0 -> OfptHello       <$> getMsg
    1 -> getOfptError len'
    2 -> OfptEchoRequest <$> getMsg
    3 -> OfptEchoReply   <$> getMsg
    4 -> return OfptVendor
    5 -> return OfptFeaturesRequest
    6 -> getOfptFeaturesReply len'
    7 -> return OfptGetConfigRequest
    8 -> OfptGetConfigReply <$> get
    9 -> OfptSetConfig      <$> get
    10 -> OfptPacketIn      <$> get
    11 -> OfptFlowRemoved   <$> get
    12 -> OfptPortStatus    <$> get
    13 -> OfptPacketOut     <$> get
    14 -> OfptFlowMod       <$> get
    15 -> OfptPortMod       <$> get
    18 -> return OfptBarrierRequest
    19 -> return OfptBarrierReply
    20 -> OfptQueueGetConfigRequest <$> get
    21 -> OfptQueueGetConfigReply <$> get
  where
    len' = fromIntegral len
    getMsg = liftM BS.unpack (getByteString (len' - ofpHdrLen))

getOfptError len = do
  ty   <- liftM fromIntegral getWord16be
  code <- liftM fromIntegral getWord16be
  OfptError <$> case ty of
    0 -> do
      bs <- getByteString (len - ofpHdrLen - 4)
      return $ OfpetHelloFailed (toEnum code :: OfpHelloFailedCode) (C.unpack bs)
    1 -> return $ OfpetBadRequest    (toEnum code :: OfpBadRequestCode)
    2 -> return $ OfpetBadAction     (toEnum code :: OfpBadActionCode)
    3 -> return $ OfpetFlowModFailed (toEnum code :: OfpFlowModFailedCode)
    4 -> return $ OfpetPortModFailed (toEnum code :: OfpPortModFailedCode)
    5 -> return $ OfpetQueueOpFailed (toEnum code :: OfpQueueOpFailedCode)
    _ -> error $ "bad error type"

getOfptFeaturesReply len = do
  dip     <- liftM fromIntegral getWord64be
  nbuf    <- liftM fromIntegral getWord32be
  ntab    <- liftM fromIntegral getWord8
  pad1    <- getWord8
  pad2    <- getWord8
  pad3    <- getWord8
  capBits <- getWord32be
  actBits <- getWord32be
  phyPortsBS <- getByteString (len - ofpHdrLen - 24)
  let caps    = word32ToEnum capBits
  let actions = word32ToEnum actBits
  let ports   = readMany phyPortsBS
  return (OfptFeaturesReply (OfpSwitchFeatures dip nbuf ntab caps actions ports))
  

-- | Socket functions    

peekHdrLen dat =
  case runGet getHdrLen dat of
    Left err -> error err
    Right len -> fromIntegral len
  where
    getHdrLen = do
      OfpHeader _ _ len _ <- get :: Get OfpHeader
      return len

readOfpFrame :: Socket -> IO OfpFrame
readOfpFrame sock = do
  dat <- recvExact ofpHdrLen
  let bytesLeft = (peekHdrLen dat) - ofpHdrLen
  if bytesLeft /= 0
    then do dat' <- recvExact bytesLeft
            case runGet get (BS.append dat dat') of
              Left err -> error err
              Right frame -> return frame
    else do case runGet get dat of
              Left err -> error err
              Right frame -> return frame              
  where
    recvExact bytes = do
      b <- recvExact' bytes BS.empty
      if BS.length b /= fromIntegral bytes
        then error "expected.."
        else return b
    recvExact' bytes buf = do
      dat <- recv sock bytes
      let len = BS.length dat
      if len == 0
        then error "peer closed connection"
        else do let buf' = BS.append buf dat
                if len >= bytes
                  then return buf'
                  else recvExact' (bytes-len) buf'
