{-# LINE 1 "src/System/Linux/RTNetlink/Packet.hsc" #-}
{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE RecordWildCards #-}
module System.Linux.RTNetlink.Packet (
NLMsgHdr(..)
, nlMsgHdrIsError
, splitMessages
, Attribute(..)
, AttributeList(..)
, AttributeType
, attributeType
, attributeData
, findAttribute
, cStringAttr
, word32Attr
, word16Attr
, Sized(..)
, putAligned
) where
import Control.Applicative ((<$>), (<*>))
import Control.Monad (guard)
import Control.Monad.Loops (unfoldM)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Maybe (runMaybeT)
import Data.Bits ((.|.), (.&.), xor)
import Data.List (unfoldr, find)
import Data.Maybe (listToMaybe)
import Data.Monoid (Monoid, mempty, mappend)
import Data.Serialize
import Data.Word (Word16,Word32)
import qualified Data.ByteString as S
{-# LINE 50 "src/System/Linux/RTNetlink/Packet.hsc" #-}
data NLMsgHdr = NLMsgHdr
{ nlMsgLength :: Word32
, nlMsgType :: Word16
, nlMsgFlags :: Word16
, nlMsgSeqNum :: Word32
, nlMsgPid :: Word32
} deriving (Show, Eq)
instance Sized NLMsgHdr where
size = const 16
{-# LINE 61 "src/System/Linux/RTNetlink/Packet.hsc" #-}
instance Serialize NLMsgHdr where
put NLMsgHdr {..} = do
putWord32host nlMsgLength
putWord16host nlMsgType
putWord16host nlMsgFlags
putWord32host nlMsgSeqNum
putWord32host nlMsgPid
get = NLMsgHdr
<$> getWord32host
<*> getWord16host
<*> getWord16host
<*> getWord32host
<*> getWord32host
nlMsgHdrType :: S.ByteString -> Word16
nlMsgHdrType = either (const 0) nlMsgType . decode
nlMsgHdrIsError :: S.ByteString -> Bool
nlMsgHdrIsError = (== 2) . nlMsgHdrType
{-# LINE 83 "src/System/Linux/RTNetlink/Packet.hsc" #-}
nlMsgHdrSize :: Integral n => S.ByteString -> n
nlMsgHdrSize = either (const 0) (fromIntegral . nlMsgLength) . decode
splitMessages :: S.ByteString -> [S.ByteString]
splitMessages = unfoldr $ \bs -> do
let sz = nlMsgHdrSize bs
guard $ sz > 0 && sz <= S.length bs
return . S.splitAt sz $ bs
class Sized s where
size :: Integral i => s -> i
sizeAligned :: Integral a => a -> s -> a
sizeAligned a s = ((size s + (a-1)) `div` a) * a
{-# MINIMAL size #-}
instance Sized () where
size = const 0
instance Sized S.ByteString where
size = fromIntegral . S.length
putAligned :: Integral a => a -> Putter S.ByteString
putAligned a bs = do
putByteString $ bs
putByteString $ S.replicate (fromIntegral $ sizeAligned a bs - size bs) 0
type AttributeType = Word16
data Attribute
= Attribute AttributeType S.ByteString
| AttributeNest AttributeType [Attribute]
deriving (Show, Eq)
instance Sized Attribute where
size (Attribute _ bs) = 4 + size bs
{-# LINE 125 "src/System/Linux/RTNetlink/Packet.hsc" #-}
size (AttributeNest _ as) = 4 + size (AttributeList as)
{-# LINE 126 "src/System/Linux/RTNetlink/Packet.hsc" #-}
instance Serialize Attribute where
put a = do
putWord16host $ size a
case a of
Attribute t bs -> do
putWord16host t
putAligned (4::Integer) bs
AttributeNest t as -> do
putWord16host $ t .|. 32768
{-# LINE 135 "src/System/Linux/RTNetlink/Packet.hsc" #-}
put $ AttributeList as
get = do
nla_len <- fromIntegral <$> getWord16host
nla_type <- getWord16host
nla_data <- getByteString $ nla_len - 4
{-# LINE 140 "src/System/Linux/RTNetlink/Packet.hsc" #-}
skip $ sizeAligned 4 nla_data - size nla_data
if nla_type .&. 32768 == 0
{-# LINE 142 "src/System/Linux/RTNetlink/Packet.hsc" #-}
then return $ Attribute nla_type nla_data
else do
AttributeList as <- get
return $ AttributeNest (nla_type `xor` 32768) as
{-# LINE 146 "src/System/Linux/RTNetlink/Packet.hsc" #-}
newtype AttributeList = AttributeList [Attribute]
deriving (Show, Eq)
instance Sized AttributeList where
size (AttributeList as) = sum $ fmap (sizeAligned 4) as
instance Serialize AttributeList where
put (AttributeList as) = mapM_ put as
get = AttributeList <$> unfoldM getMaybeAttribute
where
getMaybeAttribute = runMaybeT $ do
r <- lift $ fmap fromIntegral remaining
guard $ r >= 4
{-# LINE 159 "src/System/Linux/RTNetlink/Packet.hsc" #-}
l <- lift $ lookAhead getWord16host
guard $ l >= 4 && r >= l
{-# LINE 161 "src/System/Linux/RTNetlink/Packet.hsc" #-}
lift get
instance Monoid AttributeList where
mempty = AttributeList []
AttributeList a `mappend` AttributeList b = AttributeList $ a ++ b
cStringAttr :: AttributeType -> S.ByteString -> Attribute
cStringAttr t bs = Attribute t $ bs `S.snoc` 0
word32Attr :: AttributeType -> Word32 -> Attribute
word32Attr t = Attribute t . runPut . putWord32host
word16Attr :: AttributeType -> Word16 -> Attribute
word16Attr t = Attribute t . runPut . putWord16host
attributeType :: Attribute -> AttributeType
attributeType (Attribute t _) = t
attributeType (AttributeNest t _) = t
attributeData :: Attribute -> Maybe S.ByteString
attributeData (Attribute _ bs) = Just bs
attributeData (AttributeNest _ _) = Nothing
findAttribute :: [AttributeType] -> AttributeList -> Maybe Attribute
findAttribute ts (AttributeList as) = do
t <- listToMaybe ts
a <- find ((==t) . attributeType) as
case tail ts of
[] -> return a
ts' -> case a of
Attribute _ _ -> Nothing
AttributeNest _ as' -> findAttribute ts' (AttributeList as')