{-# LINE 1 "src/System/Linux/RTNetlink/Link.hsc" #-}
{-# 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
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
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" #-}
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" #-}
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" #-}
data AnyLink = AnyLink
deriving (Show, Eq)
instance Message AnyLink where
type MessageHeader AnyLink = IfInfoMsg
instance Request AnyLink where
requestNLFlags = dumpMany
data LinkType
= Dummy
| Bridge
| Dot1QVlan LinkIndex VlanId
| Dot1adVlan LinkIndex VlanId
| NamedLinkType S.ByteString
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" #-}
[ 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" #-}
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
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
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" #-}
}
]
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" #-}
}
]
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" #-}
}
]
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" #-}
}
]
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
, lsTxPackets :: Word64
, lsRxBytes :: Word64
, lsTxBytes :: Word64
, lsRxErrors :: Word64
, lsTxErrors :: Word64
, lsRxDropped :: Word64
, lsTxDropped :: Word64
, lsMulticast :: Word64
, lsCollisions :: Word64
, lsRxLengthErrors :: Word64
, lsRxOverErrors :: Word64
, lsRxCRCErrors :: Word64
, lsRxFrameErrors :: Word64
, lsRxFIFOErrors :: Word64
, lsRxMissedErrors :: Word64
, lsTxAbortedErrors :: Word64
, lsTxCarrierErrors :: Word64
, lsTxFIFOErrors :: Word64
, lsTxHeartbeatErrors :: Word64
, lsTxWindowErrors :: Word64
, lsRxCompressed :: Word64
, lsTxCompressed :: Word64
, lsRxNoHandler :: Word64
} 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
data IfInfoMsg = IfInfoMsg
{ ifIndex :: Int32
, ifFlags :: Word32
} 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" #-}
data IfInfoMsgPart
= IfInfoMsgIndex Int32
| IfInfoMsgFlags (ChangeFlags Word32)
deriving (Show, Eq)