{-# LINE 1 "src/System/Linux/RTNetlink/Link.hsc" #-}
{-|
Module      : System.Linux.RTNetlink.Link
Description : ADTs for creating, destroying, modifying, and getting info
              about links.
Copyright   : (c) Formaltech Inc. 2017
License     : BSD3
Maintainer  : protob3n@gmail.com
Stability   : experimental
Portability : Linux
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module System.Linux.RTNetlink.Link where

import Control.Applicative ((<$>), (<*>), (<|>))
import Control.Monad (guard)
import Data.Bits ((.&.))
import Data.Int (Int32)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Serialize
import Data.String (IsString)
import Data.Word (Word8, Word16, Word32, Word64)
import qualified Data.ByteString as S

import System.Linux.RTNetlink.Message
import System.Linux.RTNetlink.Packet
import System.Linux.RTNetlink.Util






-- | A link identified by its index.
newtype LinkIndex = LinkIndex Int
    deriving (Show, Eq, Num, Ord, Enum, Real, Integral)
instance Serialize LinkIndex where
    put ix = putWord32host $ fromIntegral ix
    get    = fromIntegral <$> getWord32host
instance Message LinkIndex where
    type MessageHeader LinkIndex      = IfInfoMsg
    messageHeaderParts (LinkIndex ix) = [IfInfoMsgIndex (fromIntegral ix)]
instance (Create c, MessageHeader c ~ IfInfoMsg) => Create (c,LinkIndex)
instance (Create c, MessageHeader c ~ IfInfoMsg) => Create (LinkIndex,c)
instance Destroy LinkIndex
instance Request LinkIndex where
    requestNLFlags = dumpOne
instance Reply LinkIndex where
    type ReplyHeader LinkIndex = IfInfoMsg
    fromNLMessage = Just . LinkIndex . fromIntegral . ifIndex . nlmHeader

-- | A link identified by its name.
newtype LinkName = LinkName S.ByteString
    deriving (Show, Eq, IsString)
instance Message LinkName where
    type MessageHeader LinkName = IfInfoMsg
    messageAttrs  (LinkName bs) = AttributeList
        [ cStringAttr 3 $ S.take 16 bs ]
{-# LINE 66 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance (Create c, MessageHeader c ~ IfInfoMsg) => Create (c,LinkName)
instance (Create c, MessageHeader c ~ IfInfoMsg) => Create (LinkName,c)
instance Change LinkIndex LinkName where
    changeAttrs n m = messageAttrs n <> messageAttrs m
instance Destroy LinkName
instance Request LinkName where
    requestNLFlags = dumpOne
instance Reply LinkName where
    type ReplyHeader LinkName = IfInfoMsg
    fromNLMessage NLMessage {..} =
        LinkName <$> findAttributeCString [3] nlmAttrs
{-# LINE 77 "src/System/Linux/RTNetlink/Link.hsc" #-}

-- | An ethernet address.
data LinkEther = LinkEther Word8 Word8 Word8 Word8 Word8 Word8
    deriving Eq
instance Show LinkEther where
    show (LinkEther a b c d e f) = showMac a b c d e f
instance Serialize LinkEther where
    put (LinkEther a b c d e f) = mapM_ put [a,b,c,d,e,f]
    get = LinkEther <$> get <*> get <*> get <*> get <*> get <*> get
instance Message LinkEther where
    type MessageHeader LinkEther = IfInfoMsg
    messageAttrs e = AttributeList [Attribute 1 $ encode e]
{-# LINE 89 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance (Create c, MessageHeader c ~ IfInfoMsg) => Create (c,LinkEther)
instance (Create c, MessageHeader c ~ IfInfoMsg) => Create (LinkEther,c)
instance Change LinkName LinkEther where
    changeAttrs n m = messageAttrs n <> messageAttrs m
instance Change LinkIndex LinkEther where
    changeAttrs n m = messageAttrs m
instance Reply LinkEther where
    type ReplyHeader LinkEther = IfInfoMsg
    fromNLMessage m = findAttributeDecode [1] $ nlmAttrs m
{-# LINE 98 "src/System/Linux/RTNetlink/Link.hsc" #-}

-- | An ethernet broadcast address.
data LinkBroadcastEther = LinkBroadcastEther Word8 Word8 Word8 Word8 Word8 Word8
    deriving Eq
instance Show LinkBroadcastEther where
    show (LinkBroadcastEther a b c d e f) = showMac a b c d e f
instance Serialize LinkBroadcastEther where
    put (LinkBroadcastEther a b c d e f) = mapM_ put [a,b,c,d,e,f]
    get = LinkBroadcastEther <$> get <*> get <*> get <*> get <*> get <*> get
instance Message LinkBroadcastEther where
    type MessageHeader LinkBroadcastEther = IfInfoMsg
    messageAttrs e = AttributeList [Attribute 2 $ encode e]
{-# LINE 110 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance (Create c, MessageHeader c ~ IfInfoMsg) => Create (c,LinkBroadcastEther)
instance (Create c, MessageHeader c ~ IfInfoMsg) => Create (LinkBroadcastEther,c)
instance Change LinkName LinkBroadcastEther where
    changeAttrs n m = messageAttrs n <> messageAttrs m
instance Change LinkIndex LinkBroadcastEther where
    changeAttrs n m = messageAttrs m
instance Reply LinkBroadcastEther where
    type ReplyHeader LinkBroadcastEther = IfInfoMsg
    fromNLMessage m = findAttributeDecode [2] $ nlmAttrs m
{-# LINE 119 "src/System/Linux/RTNetlink/Link.hsc" #-}

-- | Link wildcard.
data AnyLink = AnyLink
    deriving (Show, Eq)
instance Message AnyLink where
    type MessageHeader AnyLink = IfInfoMsg
instance Request AnyLink where
    requestNLFlags = dumpMany

-- | The type of a link.
data LinkType
    = Dummy                       -- ^ A dummy interface.
    | Bridge                      -- ^ A bridge interface.
    | Dot1QVlan  LinkIndex VlanId -- ^ An 802.1Q vlan interface.
    | Dot1adVlan LinkIndex VlanId -- ^ An 802.1ad vlan interface.
    | NamedLinkType S.ByteString  -- ^ Specify the link type name as a string.
    deriving (Show, Eq)
instance Message LinkType where
    type MessageHeader LinkType = IfInfoMsg
    messageAttrs t = case t of
        Dummy            -> setTypeName "dummy"
        Bridge           -> setTypeName "bridge"
        NamedLinkType n  -> setTypeName n
        Dot1QVlan ix vid -> messageAttrs vid
            <> setVlanProto 33024
{-# LINE 144 "src/System/Linux/RTNetlink/Link.hsc" #-}
            <> setTypeName "vlan"
            <> setVlanLink ix
        Dot1adVlan ix vid -> messageAttrs vid
            <> setVlanProto 34984
{-# LINE 148 "src/System/Linux/RTNetlink/Link.hsc" #-}
            <> setTypeName "vlan"
            <> setVlanLink ix
        where
        setTypeName n = AttributeList
            [ AttributeNest 18
{-# LINE 153 "src/System/Linux/RTNetlink/Link.hsc" #-}
                [ cStringAttr 1 n ]
{-# LINE 154 "src/System/Linux/RTNetlink/Link.hsc" #-}
            ]
        setVlanProto p = AttributeList
            [ AttributeNest 18
{-# LINE 157 "src/System/Linux/RTNetlink/Link.hsc" #-}
                [ AttributeNest 2
{-# LINE 158 "src/System/Linux/RTNetlink/Link.hsc" #-}
                    -- Weirdly, the kernel seems to want the vlan proto in BE.
                    [ word16Attr 5 (byteSwap16 p) ]
{-# LINE 160 "src/System/Linux/RTNetlink/Link.hsc" #-}
                ]
            ]
        setVlanLink ix = AttributeList
            [ word32Attr 5 (fromIntegral ix) ]
{-# LINE 164 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance Create LinkType
instance Request LinkType where
    requestNLFlags = dumpMany
instance Reply LinkType where
    type ReplyHeader LinkType = IfInfoMsg
    fromNLMessage m@(NLMessage {..}) = do
        info <- findAttributeDecode [18] nlmAttrs
{-# LINE 171 "src/System/Linux/RTNetlink/Link.hsc" #-}
        typ  <- findAttributeCString [1] info
{-# LINE 172 "src/System/Linux/RTNetlink/Link.hsc" #-}
        handleTypeName info typ
        where
        handleTypeName info t = case t of
            "dummy"  -> return Dummy
            "bridge" -> return Bridge
            "vlan"   -> handleVlan info
            _        -> return $ NamedLinkType t
        handleVlan info = do
            idata <- findAttributeDecode [2] info
{-# LINE 181 "src/System/Linux/RTNetlink/Link.hsc" #-}
            proto <- findAttributeDecode [5] idata
{-# LINE 182 "src/System/Linux/RTNetlink/Link.hsc" #-}
            case (proto::Word16) of
                (33024) -> Dot1QVlan
{-# LINE 184 "src/System/Linux/RTNetlink/Link.hsc" #-}
                    <$> getVlanLink <*> fromNLMessage m
                (34984) -> Dot1adVlan
{-# LINE 186 "src/System/Linux/RTNetlink/Link.hsc" #-}
                    <$> getVlanLink <*> fromNLMessage m
                _ -> return $ NamedLinkType "vlan"
        getVlanLink = findAttributeDecode [5] nlmAttrs
{-# LINE 189 "src/System/Linux/RTNetlink/Link.hsc" #-}

-- | Tag id for a vlan interface.
newtype VlanId = VlanId Word16
    deriving (Show, Eq, Num, Ord, Real, Enum, Integral)
instance Message VlanId where
    type MessageHeader VlanId = IfInfoMsg
    messageAttrs (VlanId vid) = AttributeList
        [ AttributeNest 18
{-# LINE 197 "src/System/Linux/RTNetlink/Link.hsc" #-}
            [ AttributeNest 2
{-# LINE 198 "src/System/Linux/RTNetlink/Link.hsc" #-}
                [ word16Attr 1 vid ]
{-# LINE 199 "src/System/Linux/RTNetlink/Link.hsc" #-}
            ]
        ]
instance Reply VlanId where
    type ReplyHeader VlanId = IfInfoMsg
    fromNLMessage NLMessage {..} = do
        info  <- findAttributeDecode [18] nlmAttrs
{-# LINE 205 "src/System/Linux/RTNetlink/Link.hsc" #-}
        idata <- findAttributeDecode [2] info
{-# LINE 206 "src/System/Linux/RTNetlink/Link.hsc" #-}
        vid   <- findAttributeGet getWord16host [1] idata
{-# LINE 207 "src/System/Linux/RTNetlink/Link.hsc" #-}
        return $ VlanId vid

-- | The master interface for this interface for this one. For example, a bridge
-- interface.
data LinkMaster = Master LinkIndex | NoMaster
    deriving (Show, Eq)
instance Message LinkMaster where
    type MessageHeader LinkMaster = IfInfoMsg
    messageAttrs (Master n) = AttributeList [word32Attr 10 $ fromIntegral n]
{-# LINE 216 "src/System/Linux/RTNetlink/Link.hsc" #-}
    messageAttrs NoMaster   = AttributeList [word32Attr 10 0]
{-# LINE 217 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance Reply LinkMaster where
    type ReplyHeader LinkMaster = IfInfoMsg
    fromNLMessage NLMessage {..} = Just . fromMaybe NoMaster $ do
        ix <- findAttributeDecode [10] nlmAttrs
{-# LINE 221 "src/System/Linux/RTNetlink/Link.hsc" #-}
        guard $ ix > 0
        return $ Master ix
instance Change LinkName LinkMaster where
    changeAttrs n m = messageAttrs n <> messageAttrs m
instance Change LinkIndex LinkMaster where
    changeAttrs n m = messageAttrs m

-- | The state of a link.
data LinkState = Up | Down
    deriving (Show, Eq)
instance Reply LinkState where
    type ReplyHeader LinkState = IfInfoMsg
    fromNLMessage m = Just $ if flag == 0 then Down else Up
        where flag = ifFlags (nlmHeader m) .&. 1
{-# LINE 235 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance Change LinkName LinkState where
    changeHeaderParts n s =
        [ IfInfoMsgFlags $ ChangeFlags
            { cfFlags = if s == Up then 1 else 0
{-# LINE 239 "src/System/Linux/RTNetlink/Link.hsc" #-}
            , cfMask  = 1
{-# LINE 240 "src/System/Linux/RTNetlink/Link.hsc" #-}
            }
        ]
instance Change LinkIndex LinkState where
    changeHeaderParts n s =
        [ IfInfoMsgIndex $ fromIntegral n
        , IfInfoMsgFlags $ ChangeFlags
            { cfFlags = if s == Up then 1 else 0
{-# LINE 247 "src/System/Linux/RTNetlink/Link.hsc" #-}
            , cfMask  = 1
{-# LINE 248 "src/System/Linux/RTNetlink/Link.hsc" #-}
            }
        ]

-- | A 'Promiscuous' link accepts all frames at layer 2; a 'Chaste' one accepts
-- just those addressed to it and possibly ones sent to the broadcast address.
data LinkPromiscuity = Promiscuous | Chaste
    deriving (Show, Eq)
instance Reply LinkPromiscuity where
    type ReplyHeader LinkPromiscuity = IfInfoMsg
    fromNLMessage m = Just $ if flag == 0 then Chaste else Promiscuous
        where flag = ifFlags (nlmHeader m) .&. 256
{-# LINE 259 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance Change LinkName LinkPromiscuity where
    changeHeaderParts n s =
        [ IfInfoMsgFlags $ ChangeFlags
            { cfFlags = if s == Promiscuous then 256 else 0
{-# LINE 263 "src/System/Linux/RTNetlink/Link.hsc" #-}
            , cfMask  = 256
{-# LINE 264 "src/System/Linux/RTNetlink/Link.hsc" #-}
            }
        ]
instance Change LinkIndex LinkPromiscuity where
    changeHeaderParts n s =
        [ IfInfoMsgIndex $ fromIntegral n
        , IfInfoMsgFlags $ ChangeFlags
            { cfFlags = if s == Promiscuous then 256 else 0
{-# LINE 271 "src/System/Linux/RTNetlink/Link.hsc" #-}
            , cfMask  = 256
{-# LINE 272 "src/System/Linux/RTNetlink/Link.hsc" #-}
            }
        ]

-- | Whether to use ARP on the interface to resolve L3 addresses to L2 ones.
data LinkArp = Arp | NoArp
    deriving (Show, Eq)
instance Reply LinkArp where
    type ReplyHeader LinkArp = IfInfoMsg
    fromNLMessage m = Just $ if flag == 0 then Arp else NoArp
        where flag = ifFlags (nlmHeader m) .&. 128
{-# LINE 282 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance Change LinkName LinkArp where
    changeHeaderParts n s =
        [ IfInfoMsgFlags $ ChangeFlags
            { cfFlags = if s == NoArp then 128 else 0
{-# LINE 286 "src/System/Linux/RTNetlink/Link.hsc" #-}
            , cfMask  = 128
{-# LINE 287 "src/System/Linux/RTNetlink/Link.hsc" #-}
            }
        ]
instance Change LinkIndex LinkArp where
    changeHeaderParts n s =
        [ IfInfoMsgIndex $ fromIntegral n
        , IfInfoMsgFlags $ ChangeFlags
            { cfFlags = if s == NoArp then 128 else 0
{-# LINE 294 "src/System/Linux/RTNetlink/Link.hsc" #-}
            , cfMask  = 128
{-# LINE 295 "src/System/Linux/RTNetlink/Link.hsc" #-}
            }
        ]

-- | Internal debug flag. If this is supported by the driver, it will generally
-- spew some extra information into @dmesg@.
data LinkDebug = Debug | NoDebug
    deriving (Show, Eq)
instance Reply LinkDebug where
    type ReplyHeader LinkDebug = IfInfoMsg
    fromNLMessage m = Just $ if flag == 0 then NoDebug else Debug
        where flag = ifFlags (nlmHeader m) .&. 4
{-# LINE 306 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance Change LinkName LinkDebug where
    changeHeaderParts _ s =
        [ IfInfoMsgFlags $ ChangeFlags
            { cfFlags = if s == Debug then 4 else 0
{-# LINE 310 "src/System/Linux/RTNetlink/Link.hsc" #-}
            , cfMask  = 4
{-# LINE 311 "src/System/Linux/RTNetlink/Link.hsc" #-}
            }
        ]
instance Change LinkIndex LinkDebug where
    changeHeaderParts n s =
        [ IfInfoMsgIndex $ fromIntegral n
        , IfInfoMsgFlags $ ChangeFlags
            { cfFlags = if s == Debug then 4 else 0
{-# LINE 318 "src/System/Linux/RTNetlink/Link.hsc" #-}
            , cfMask  = 4
{-# LINE 319 "src/System/Linux/RTNetlink/Link.hsc" #-}
            }
        ]

-- | Maximum transmission unit for a link. Note that some interface types, such
-- as 'Bridge's, don't allow this to be changed.
newtype LinkMTU = LinkMTU Word32
    deriving (Show, Eq, Num, Ord, Enum, Real, Integral)
instance Message LinkMTU where
    type MessageHeader LinkMTU = IfInfoMsg
    messageAttrs (LinkMTU mtu) =
        AttributeList [word32Attr 4 mtu]
{-# LINE 330 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance Change LinkName LinkMTU where
    changeAttrs n m = messageAttrs n <> messageAttrs m
instance Change LinkIndex LinkMTU where
    changeAttrs _ m = messageAttrs m
instance Reply LinkMTU where
    type ReplyHeader LinkMTU = IfInfoMsg
    fromNLMessage NLMessage{..} = LinkMTU
        <$> findAttributeGet getWord32host [4] nlmAttrs
{-# LINE 338 "src/System/Linux/RTNetlink/Link.hsc" #-}

newtype LinkGroup = LinkGroup Word32
    deriving (Show, Eq, Num, Ord, Enum, Real, Integral)
instance Change LinkName LinkGroup where
    changeAttrs n (LinkGroup g) = messageAttrs n <>
        AttributeList [word32Attr 27 g]
{-# LINE 344 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance Change LinkIndex LinkGroup where
    changeAttrs _ (LinkGroup g) = AttributeList [word32Attr 27 g]
{-# LINE 346 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance Reply LinkGroup where
    type ReplyHeader LinkGroup = IfInfoMsg
    fromNLMessage NLMessage {..} = LinkGroup
        <$> findAttributeGet getWord32host [27] nlmAttrs
{-# LINE 350 "src/System/Linux/RTNetlink/Link.hsc" #-}

data LinkStats = LinkStats
    { lsRxPackets         :: Word64 -- ^ Total packets received.
    , lsTxPackets         :: Word64 -- ^ Total packets transmitted.
    , lsRxBytes           :: Word64 -- ^ Total bytes received.
    , lsTxBytes           :: Word64 -- ^ Total bytes transmitted.
    , lsRxErrors          :: Word64 -- ^ Bad packets received.
    , lsTxErrors          :: Word64 -- ^ Packet transmission problems.
    , lsRxDropped         :: Word64 -- ^ Dropped due to full buffers.
    , lsTxDropped         :: Word64 -- ^ Out of memory.
    , lsMulticast         :: Word64 -- ^ Multicast packets received.
    , lsCollisions        :: Word64 -- ^ Packet collisions.
    , lsRxLengthErrors    :: Word64 -- ^ Size/header mismatch.
    , lsRxOverErrors      :: Word64 -- ^ Receive ring-buffer overflow.
    , lsRxCRCErrors       :: Word64 -- ^ CRC errors.
    , lsRxFrameErrors     :: Word64 -- ^ Frame-alignment errors.
    , lsRxFIFOErrors      :: Word64 -- ^ Receiver FIFO overrun.
    , lsRxMissedErrors    :: Word64 -- ^ Receiver missed packets.
    , lsTxAbortedErrors   :: Word64
    , lsTxCarrierErrors   :: Word64
    , lsTxFIFOErrors      :: Word64
    , lsTxHeartbeatErrors :: Word64
    , lsTxWindowErrors    :: Word64
    , lsRxCompressed      :: Word64
    , lsTxCompressed      :: Word64
    , lsRxNoHandler       :: Word64 -- ^ Dropped due to lack of handler.
    } deriving (Show, Eq)
instance Reply LinkStats where
    type ReplyHeader LinkStats = IfInfoMsg
    fromNLMessage NLMessage {..} =
            findAttributeGet (get' getWord64host) [23] nlmAttrs
{-# LINE 381 "src/System/Linux/RTNetlink/Link.hsc" #-}
        <|> findAttributeGet (get' getWord32host) [7] nlmAttrs
{-# LINE 382 "src/System/Linux/RTNetlink/Link.hsc" #-}
        where
        get' getter = let g = fromIntegral <$> getter in LinkStats
           <$>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g
           <*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g<*>g

-- | The header corresponding to link messages, based on @struct ifinfomsg@
-- from @linux/if_link.h@.
data IfInfoMsg = IfInfoMsg
    { ifIndex  :: Int32  -- ^ The index of the link.
    , ifFlags  :: Word32 -- ^ Operational flags of the link.
    } deriving (Show, Eq)
instance Sized IfInfoMsg where
    size = const 16
{-# LINE 395 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance Serialize IfInfoMsg where
    put IfInfoMsg {..} = do
        putWord8      0
{-# LINE 398 "src/System/Linux/RTNetlink/Link.hsc" #-}
        putWord8      0
        putWord16host 0
        putInt32host  ifIndex
        putWord32host ifFlags
        putWord32host 0xffffffff
    get = do
        skip 4
        ifIndex <- getInt32le
        ifFlags <- getWord32host
        _change <- getWord32host
        return $ IfInfoMsg {..}
instance Header IfInfoMsg where
    type HeaderPart IfInfoMsg = IfInfoMsgPart
    fromHeaderParts = toHeader . foldr modify (0,mempty)
        where
        toHeader                   (ix,f) = IfInfoMsg ix $ cfFlags f
        modify (IfInfoMsgIndex ix) (_, f) = (ix, f)
        modify (IfInfoMsgFlags f)  (ix,g) = (ix, f <> g)
    emptyHeader = IfInfoMsg 0 0
instance CreateMessageHeader IfInfoMsg where
    createTypeNumber = const 16
{-# LINE 419 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance DestroyMessageHeader IfInfoMsg where
    destroyTypeNumber = const 17
{-# LINE 421 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance ChangeMessageHeader IfInfoMsg where
    changeTypeNumber = const 19
{-# LINE 423 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance RequestMessageHeader IfInfoMsg where
    requestTypeNumber = const 18
{-# LINE 425 "src/System/Linux/RTNetlink/Link.hsc" #-}
instance ReplyMessageHeader IfInfoMsg where
    replyTypeNumbers = const [16]
{-# LINE 427 "src/System/Linux/RTNetlink/Link.hsc" #-}

-- | Combinable components of an IfInfoMsg.
data IfInfoMsgPart
    = IfInfoMsgIndex Int32
    | IfInfoMsgFlags (ChangeFlags Word32)
    deriving (Show, Eq)