{-# LANGUAGE CPP #-}
{-|
Module      : System.Linux.Netlink.GeNetlink.Control
Description : This module implements the control protocol of genetlink
Maintainer  : ongy
Stability   : testing
Portability : Linux

This module provides utility functions and datatypes for the genetlink control
protocol.
This has to be used by implementations of netlink families based on genetlink
to lookup their current id, since that is determined at runtime.
-}

module System.Linux.Netlink.GeNetlink.Control
  ( CtrlAttribute(..)
  , CtrlAttrMcastGroup(..)
  , CtrlPacket(..)
  , CTRLPacket
  , ctrlPacketFromGenl
  , CtrlAttrOpData(..)

  , ctrlPackettoGenl
  , getFamilyId
  , getFamilyIdS
  , getFamilyWithMulticasts
  , getFamilyWithMulticastsS
  , getMulticastGroups
  , getMulticast
  , getFamilie
  , getFamilies
  )
where

#if MIN_VERSION_base(4,8,0)
#else
import Control.Applicative ((<$>))
#endif

import Data.Bits ((.|.))
import Data.Serialize.Get
import Data.Serialize.Put
import Data.List (intercalate)
import Data.Map (fromList, lookup, toList, Map)
import Data.ByteString (ByteString, append, empty)
import Data.ByteString.Char8 (pack, unpack)
import Data.Word (Word16, Word32)
import Data.Maybe (fromMaybe, mapMaybe)

import Prelude hiding (lookup)

import System.Linux.Netlink
import System.Linux.Netlink.Constants
import System.Linux.Netlink.GeNetlink
import System.Linux.Netlink.GeNetlink.Constants
import System.Linux.Netlink.Helpers (g32, g16)

-- |Datatype for multicast groups as returned by the control protocol
data CtrlAttrMcastGroup = CAMG {CtrlAttrMcastGroup -> [Char]
grpName :: String, CtrlAttrMcastGroup -> Word32
grpId :: Word32 } deriving (CtrlAttrMcastGroup -> CtrlAttrMcastGroup -> Bool
(CtrlAttrMcastGroup -> CtrlAttrMcastGroup -> Bool)
-> (CtrlAttrMcastGroup -> CtrlAttrMcastGroup -> Bool)
-> Eq CtrlAttrMcastGroup
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CtrlAttrMcastGroup -> CtrlAttrMcastGroup -> Bool
== :: CtrlAttrMcastGroup -> CtrlAttrMcastGroup -> Bool
$c/= :: CtrlAttrMcastGroup -> CtrlAttrMcastGroup -> Bool
/= :: CtrlAttrMcastGroup -> CtrlAttrMcastGroup -> Bool
Eq, Int -> CtrlAttrMcastGroup -> ShowS
[CtrlAttrMcastGroup] -> ShowS
CtrlAttrMcastGroup -> [Char]
(Int -> CtrlAttrMcastGroup -> ShowS)
-> (CtrlAttrMcastGroup -> [Char])
-> ([CtrlAttrMcastGroup] -> ShowS)
-> Show CtrlAttrMcastGroup
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CtrlAttrMcastGroup -> ShowS
showsPrec :: Int -> CtrlAttrMcastGroup -> ShowS
$cshow :: CtrlAttrMcastGroup -> [Char]
show :: CtrlAttrMcastGroup -> [Char]
$cshowList :: [CtrlAttrMcastGroup] -> ShowS
showList :: [CtrlAttrMcastGroup] -> ShowS
Show)
-- |Datatype for AttrOpData as returned by the control protocol
data CtrlAttrOpData = CAO {CtrlAttrOpData -> Word32
opId :: Word32, CtrlAttrOpData -> Word32
opFlags :: Word32 } deriving (CtrlAttrOpData -> CtrlAttrOpData -> Bool
(CtrlAttrOpData -> CtrlAttrOpData -> Bool)
-> (CtrlAttrOpData -> CtrlAttrOpData -> Bool) -> Eq CtrlAttrOpData
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CtrlAttrOpData -> CtrlAttrOpData -> Bool
== :: CtrlAttrOpData -> CtrlAttrOpData -> Bool
$c/= :: CtrlAttrOpData -> CtrlAttrOpData -> Bool
/= :: CtrlAttrOpData -> CtrlAttrOpData -> Bool
Eq, Int -> CtrlAttrOpData -> ShowS
[CtrlAttrOpData] -> ShowS
CtrlAttrOpData -> [Char]
(Int -> CtrlAttrOpData -> ShowS)
-> (CtrlAttrOpData -> [Char])
-> ([CtrlAttrOpData] -> ShowS)
-> Show CtrlAttrOpData
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CtrlAttrOpData -> ShowS
showsPrec :: Int -> CtrlAttrOpData -> ShowS
$cshow :: CtrlAttrOpData -> [Char]
show :: CtrlAttrOpData -> [Char]
$cshowList :: [CtrlAttrOpData] -> ShowS
showList :: [CtrlAttrOpData] -> ShowS
Show)

-- |Attributes defined by the control family
data CtrlAttribute =
  CTRL_ATTR_UNSPEC       ByteString |
  CTRL_ATTR_FAMILY_ID    Word16 |
  CTRL_ATTR_FAMILY_NAME  String |
  CTRL_ATTR_VERSION      Word32 |
  CTRL_ATTR_HDRSIZE      Word32 |
  CTRL_ATTR_MAXATTR      Word32 |
  CTRL_ATTR_OPS          [CtrlAttrOpData] |
  CTRL_ATTR_MCAST_GROUPS [CtrlAttrMcastGroup] |
  CTRL_ATTR_UNKNOWN      Int ByteString
  deriving (CtrlAttribute -> CtrlAttribute -> Bool
(CtrlAttribute -> CtrlAttribute -> Bool)
-> (CtrlAttribute -> CtrlAttribute -> Bool) -> Eq CtrlAttribute
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CtrlAttribute -> CtrlAttribute -> Bool
== :: CtrlAttribute -> CtrlAttribute -> Bool
$c/= :: CtrlAttribute -> CtrlAttribute -> Bool
/= :: CtrlAttribute -> CtrlAttribute -> Bool
Eq, Int -> CtrlAttribute -> ShowS
[CtrlAttribute] -> ShowS
CtrlAttribute -> [Char]
(Int -> CtrlAttribute -> ShowS)
-> (CtrlAttribute -> [Char])
-> ([CtrlAttribute] -> ShowS)
-> Show CtrlAttribute
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CtrlAttribute -> ShowS
showsPrec :: Int -> CtrlAttribute -> ShowS
$cshow :: CtrlAttribute -> [Char]
show :: CtrlAttribute -> [Char]
$cshowList :: [CtrlAttribute] -> ShowS
showList :: [CtrlAttribute] -> ShowS
Show)


-- |Typesafe control packet
data CtrlPacket = CtrlPacket
    {
      CtrlPacket -> Header
ctrlHeader     :: Header
    , CtrlPacket -> GenlHeader
ctrlGeHeader   :: GenlHeader
    , CtrlPacket -> [CtrlAttribute]
ctrlAttributes :: [CtrlAttribute]
    } deriving (CtrlPacket -> CtrlPacket -> Bool
(CtrlPacket -> CtrlPacket -> Bool)
-> (CtrlPacket -> CtrlPacket -> Bool) -> Eq CtrlPacket
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CtrlPacket -> CtrlPacket -> Bool
== :: CtrlPacket -> CtrlPacket -> Bool
$c/= :: CtrlPacket -> CtrlPacket -> Bool
/= :: CtrlPacket -> CtrlPacket -> Bool
Eq)


instance Show CtrlPacket where
  show :: CtrlPacket -> [Char]
show CtrlPacket
packet = 
    Header -> [Char]
forall a. Show a => a -> [Char]
show (CtrlPacket -> Header
ctrlHeader CtrlPacket
packet) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'\n'Char -> ShowS
forall a. a -> [a] -> [a]
:GenlHeader -> [Char]
forall a. Show a => a -> [Char]
show (CtrlPacket -> GenlHeader
ctrlGeHeader CtrlPacket
packet) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
    [Char]
"Attrs:\n" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n" ((CtrlAttribute -> [Char]) -> [CtrlAttribute] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map CtrlAttribute -> [Char]
forall a. Show a => a -> [Char]
show (CtrlPacket -> [CtrlAttribute]
ctrlAttributes CtrlPacket
packet))


-- |typedef for control messages
type CTRLPacket = GenlPacket NoData

--
-- Start ctrl utility
--

getW16 :: ByteString -> Maybe Word16
getW16 :: ByteString -> Maybe Word16
getW16 ByteString
x = Either [Char] Word16 -> Maybe Word16
forall a b. Either a b -> Maybe b
e2M (Get Word16 -> ByteString -> Either [Char] Word16
forall a. Get a -> ByteString -> Either [Char] a
runGet Get Word16
g16 ByteString
x)

getW32 :: ByteString -> Maybe Word32
getW32 :: ByteString -> Maybe Word32
getW32 ByteString
x = Either [Char] Word32 -> Maybe Word32
forall a b. Either a b -> Maybe b
e2M (Get Word32 -> ByteString -> Either [Char] Word32
forall a. Get a -> ByteString -> Either [Char] a
runGet Get Word32
g32 ByteString
x)

e2M :: Either a b -> Maybe b
e2M :: forall a b. Either a b -> Maybe b
e2M (Right b
x) = b -> Maybe b
forall a. a -> Maybe a
Just b
x
e2M Either a b
_ = Maybe b
forall a. Maybe a
Nothing

getMcastGroupAttr :: (Int, ByteString) -> Maybe CtrlAttrMcastGroup
getMcastGroupAttr :: (Int, ByteString) -> Maybe CtrlAttrMcastGroup
getMcastGroupAttr (Int
_, ByteString
x) = do
  attrs <- Either [Char] Attributes -> Maybe Attributes
forall a b. Either a b -> Maybe b
e2M (Either [Char] Attributes -> Maybe Attributes)
-> Either [Char] Attributes -> Maybe Attributes
forall a b. (a -> b) -> a -> b
$Get Attributes -> ByteString -> Either [Char] Attributes
forall a. Get a -> ByteString -> Either [Char] a
runGet Get Attributes
getAttributes ByteString
x
  name <- lookup eCTRL_ATTR_MCAST_GRP_NAME attrs
  fid  <- lookup eCTRL_ATTR_MCAST_GRP_ID attrs
  -- This init is ok because the name will always have the \0
  CAMG (init . unpack $ name) <$> getW32 fid

getMcastGroupAttrs :: ByteString -> Maybe [CtrlAttrMcastGroup]
getMcastGroupAttrs :: ByteString -> Maybe [CtrlAttrMcastGroup]
getMcastGroupAttrs ByteString
x = case Get Attributes -> ByteString -> Either [Char] Attributes
forall a. Get a -> ByteString -> Either [Char] a
runGet Get Attributes
getAttributes ByteString
x of
  (Right Attributes
y) -> ((Int, ByteString) -> Maybe CtrlAttrMcastGroup)
-> [(Int, ByteString)] -> Maybe [CtrlAttrMcastGroup]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Int, ByteString) -> Maybe CtrlAttrMcastGroup
getMcastGroupAttr ([(Int, ByteString)] -> Maybe [CtrlAttrMcastGroup])
-> [(Int, ByteString)] -> Maybe [CtrlAttrMcastGroup]
forall a b. (a -> b) -> a -> b
$ Attributes -> [(Int, ByteString)]
forall k a. Map k a -> [(k, a)]
toList Attributes
y
  Either [Char] Attributes
_ -> Maybe [CtrlAttrMcastGroup]
forall a. Maybe a
Nothing

getOpAttr :: (Int, ByteString) -> Maybe CtrlAttrOpData
getOpAttr :: (Int, ByteString) -> Maybe CtrlAttrOpData
getOpAttr (Int
_, ByteString
x) = do
  attrs <- Either [Char] Attributes -> Maybe Attributes
forall a b. Either a b -> Maybe b
e2M (Either [Char] Attributes -> Maybe Attributes)
-> Either [Char] Attributes -> Maybe Attributes
forall a b. (a -> b) -> a -> b
$Get Attributes -> ByteString -> Either [Char] Attributes
forall a. Get a -> ByteString -> Either [Char] a
runGet Get Attributes
getAttributes ByteString
x
  oid <- getW32 =<< lookup eCTRL_ATTR_OP_ID attrs
  ofl <- getW32 =<< lookup eCTRL_ATTR_OP_FLAGS attrs
  return $ CAO oid ofl

getOpAttrs :: ByteString -> Maybe [CtrlAttrOpData]
getOpAttrs :: ByteString -> Maybe [CtrlAttrOpData]
getOpAttrs ByteString
x = case Get Attributes -> ByteString -> Either [Char] Attributes
forall a. Get a -> ByteString -> Either [Char] a
runGet Get Attributes
getAttributes ByteString
x of
  (Right Attributes
y) -> ((Int, ByteString) -> Maybe CtrlAttrOpData)
-> [(Int, ByteString)] -> Maybe [CtrlAttrOpData]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Int, ByteString) -> Maybe CtrlAttrOpData
getOpAttr ([(Int, ByteString)] -> Maybe [CtrlAttrOpData])
-> [(Int, ByteString)] -> Maybe [CtrlAttrOpData]
forall a b. (a -> b) -> a -> b
$ Attributes -> [(Int, ByteString)]
forall k a. Map k a -> [(k, a)]
toList Attributes
y
  Either [Char] Attributes
_ -> Maybe [CtrlAttrOpData]
forall a. Maybe a
Nothing

getAttribute :: (Int, ByteString) -> CtrlAttribute
getAttribute :: (Int, ByteString) -> CtrlAttribute
getAttribute (Int
i, ByteString
x) = CtrlAttribute -> Maybe CtrlAttribute -> CtrlAttribute
forall a. a -> Maybe a -> a
fromMaybe (Int -> ByteString -> CtrlAttribute
CTRL_ATTR_UNKNOWN Int
i ByteString
x) (Maybe CtrlAttribute -> CtrlAttribute)
-> Maybe CtrlAttribute -> CtrlAttribute
forall a b. (a -> b) -> a -> b
$Int -> ByteString -> Maybe CtrlAttribute
makeAttribute Int
i ByteString
x

makeAttribute :: Int -> ByteString -> Maybe CtrlAttribute
makeAttribute :: Int -> ByteString -> Maybe CtrlAttribute
makeAttribute Int
i ByteString
x
  | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Num a => a
eCTRL_ATTR_UNSPEC = CtrlAttribute -> Maybe CtrlAttribute
forall a. a -> Maybe a
Just (CtrlAttribute -> Maybe CtrlAttribute)
-> CtrlAttribute -> Maybe CtrlAttribute
forall a b. (a -> b) -> a -> b
$ByteString -> CtrlAttribute
CTRL_ATTR_UNSPEC ByteString
x
  | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Num a => a
eCTRL_ATTR_FAMILY_ID = (Word16 -> CtrlAttribute) -> Maybe Word16 -> Maybe CtrlAttribute
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word16 -> CtrlAttribute
CTRL_ATTR_FAMILY_ID (Maybe Word16 -> Maybe CtrlAttribute)
-> Maybe Word16 -> Maybe CtrlAttribute
forall a b. (a -> b) -> a -> b
$ByteString -> Maybe Word16
getW16 ByteString
x
  | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Num a => a
eCTRL_ATTR_FAMILY_NAME = CtrlAttribute -> Maybe CtrlAttribute
forall a. a -> Maybe a
Just (CtrlAttribute -> Maybe CtrlAttribute)
-> ([Char] -> CtrlAttribute) -> [Char] -> Maybe CtrlAttribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> CtrlAttribute
CTRL_ATTR_FAMILY_NAME ([Char] -> CtrlAttribute) -> ShowS -> [Char] -> CtrlAttribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. HasCallStack => [a] -> [a]
init ([Char] -> Maybe CtrlAttribute) -> [Char] -> Maybe CtrlAttribute
forall a b. (a -> b) -> a -> b
$ByteString -> [Char]
unpack ByteString
x
  | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Num a => a
eCTRL_ATTR_VERSION = (Word32 -> CtrlAttribute) -> Maybe Word32 -> Maybe CtrlAttribute
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> CtrlAttribute
CTRL_ATTR_VERSION (Maybe Word32 -> Maybe CtrlAttribute)
-> Maybe Word32 -> Maybe CtrlAttribute
forall a b. (a -> b) -> a -> b
$ByteString -> Maybe Word32
getW32 ByteString
x
  | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Num a => a
eCTRL_ATTR_HDRSIZE = (Word32 -> CtrlAttribute) -> Maybe Word32 -> Maybe CtrlAttribute
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> CtrlAttribute
CTRL_ATTR_HDRSIZE (Maybe Word32 -> Maybe CtrlAttribute)
-> Maybe Word32 -> Maybe CtrlAttribute
forall a b. (a -> b) -> a -> b
$ByteString -> Maybe Word32
getW32 ByteString
x
  | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Num a => a
eCTRL_ATTR_MAXATTR = (Word32 -> CtrlAttribute) -> Maybe Word32 -> Maybe CtrlAttribute
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> CtrlAttribute
CTRL_ATTR_MAXATTR (Maybe Word32 -> Maybe CtrlAttribute)
-> Maybe Word32 -> Maybe CtrlAttribute
forall a b. (a -> b) -> a -> b
$ByteString -> Maybe Word32
getW32 ByteString
x
  | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Num a => a
eCTRL_ATTR_OPS = ([CtrlAttrOpData] -> CtrlAttribute)
-> Maybe [CtrlAttrOpData] -> Maybe CtrlAttribute
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [CtrlAttrOpData] -> CtrlAttribute
CTRL_ATTR_OPS (Maybe [CtrlAttrOpData] -> Maybe CtrlAttribute)
-> Maybe [CtrlAttrOpData] -> Maybe CtrlAttribute
forall a b. (a -> b) -> a -> b
$ByteString -> Maybe [CtrlAttrOpData]
getOpAttrs ByteString
x
  | Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
forall a. Num a => a
eCTRL_ATTR_MCAST_GROUPS = ([CtrlAttrMcastGroup] -> CtrlAttribute)
-> Maybe [CtrlAttrMcastGroup] -> Maybe CtrlAttribute
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [CtrlAttrMcastGroup] -> CtrlAttribute
CTRL_ATTR_MCAST_GROUPS (Maybe [CtrlAttrMcastGroup] -> Maybe CtrlAttribute)
-> Maybe [CtrlAttrMcastGroup] -> Maybe CtrlAttribute
forall a b. (a -> b) -> a -> b
$ByteString -> Maybe [CtrlAttrMcastGroup]
getMcastGroupAttrs ByteString
x
  | Bool
otherwise = Maybe CtrlAttribute
forall a. Maybe a
Nothing


ctrlAttributesFromAttributes :: Map Int ByteString -> [CtrlAttribute]
ctrlAttributesFromAttributes :: Attributes -> [CtrlAttribute]
ctrlAttributesFromAttributes = ((Int, ByteString) -> CtrlAttribute)
-> [(Int, ByteString)] -> [CtrlAttribute]
forall a b. (a -> b) -> [a] -> [b]
map (Int, ByteString) -> CtrlAttribute
getAttribute ([(Int, ByteString)] -> [CtrlAttribute])
-> (Attributes -> [(Int, ByteString)])
-> Attributes
-> [CtrlAttribute]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attributes -> [(Int, ByteString)]
forall k a. Map k a -> [(k, a)]
toList

-- |Convert "normal" 'Packet's into typesafe 'CtrlPacket's
ctrlPacketFromGenl :: CTRLPacket -> Maybe CtrlPacket
ctrlPacketFromGenl :: CTRLPacket -> Maybe CtrlPacket
ctrlPacketFromGenl (Packet Header
h GenlData NoData
g Attributes
attrs) = CtrlPacket -> Maybe CtrlPacket
forall a. a -> Maybe a
Just (Header -> GenlHeader -> [CtrlAttribute] -> CtrlPacket
CtrlPacket Header
h (GenlData NoData -> GenlHeader
forall a. GenlData a -> GenlHeader
genlDataHeader GenlData NoData
g) [CtrlAttribute]
a)
  where a :: [CtrlAttribute]
a = Attributes -> [CtrlAttribute]
ctrlAttributesFromAttributes Attributes
attrs
ctrlPacketFromGenl CTRLPacket
_ = Maybe CtrlPacket
forall a. Maybe a
Nothing


putW16 :: Word16 -> ByteString
putW16 :: Word16 -> ByteString
putW16 Word16
x = Put -> ByteString
runPut (Putter Word16
putWord16host Word16
x)


putW32 :: Word32 -> ByteString
putW32 :: Word32 -> ByteString
putW32 Word32
x = Put -> ByteString
runPut (Putter Word32
putWord32host Word32
x)


-- AttrOps and McastGroup are broken, but generally we shouldn't send these anyway
cATA :: CtrlAttribute -> (Int, ByteString)
cATA :: CtrlAttribute -> (Int, ByteString)
cATA (CTRL_ATTR_UNSPEC       ByteString
x) = (Int
forall a. Num a => a
eCTRL_ATTR_UNSPEC      , ByteString
x)
cATA (CTRL_ATTR_FAMILY_ID    Word16
x) = (Int
forall a. Num a => a
eCTRL_ATTR_FAMILY_ID   , Word16 -> ByteString
putW16 Word16
x)
cATA (CTRL_ATTR_FAMILY_NAME  [Char]
x) = (Int
forall a. Num a => a
eCTRL_ATTR_FAMILY_NAME , [Char] -> ByteString
pack ([Char]
x [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
"\n"))
cATA (CTRL_ATTR_VERSION      Word32
x) = (Int
forall a. Num a => a
eCTRL_ATTR_VERSION     , Word32 -> ByteString
putW32 Word32
x)
cATA (CTRL_ATTR_HDRSIZE      Word32
x) = (Int
forall a. Num a => a
eCTRL_ATTR_HDRSIZE     , Word32 -> ByteString
putW32 Word32
x)
cATA (CTRL_ATTR_MAXATTR      Word32
x) = (Int
forall a. Num a => a
eCTRL_ATTR_MAXATTR     , Word32 -> ByteString
putW32 Word32
x)
cATA (CTRL_ATTR_OPS          [CtrlAttrOpData]
_) = (Int
forall a. Num a => a
eCTRL_ATTR_OPS         , ByteString
empty)
cATA (CTRL_ATTR_MCAST_GROUPS [CtrlAttrMcastGroup]
_) = (Int
forall a. Num a => a
eCTRL_ATTR_MCAST_GROUPS, ByteString
empty)
cATA (CTRL_ATTR_UNKNOWN    Int
i ByteString
x) = (Int
i                      , ByteString
x)


ctrlAttributesToAttribute :: CtrlAttribute -> (Int, ByteString)
ctrlAttributesToAttribute :: CtrlAttribute -> (Int, ByteString)
ctrlAttributesToAttribute = CtrlAttribute -> (Int, ByteString)
cATA


-- |Convert the typesafe 'CtrPacket' into a 'CTRLPacket' so it can be sent
ctrlPackettoGenl :: CtrlPacket -> CTRLPacket
ctrlPackettoGenl :: CtrlPacket -> CTRLPacket
ctrlPackettoGenl (CtrlPacket Header
h GenlHeader
g [CtrlAttribute]
attrs)= Header -> GenlData NoData -> Attributes -> CTRLPacket
forall a. Header -> a -> Attributes -> Packet a
Packet Header
h (GenlHeader -> NoData -> GenlData NoData
forall a. GenlHeader -> a -> GenlData a
GenlData GenlHeader
g NoData
NoData) Attributes
a
  where a :: Attributes
a = [(Int, ByteString)] -> Attributes
forall k a. Ord k => [(k, a)] -> Map k a
fromList ([(Int, ByteString)] -> Attributes)
-> [(Int, ByteString)] -> Attributes
forall a b. (a -> b) -> a -> b
$(CtrlAttribute -> (Int, ByteString))
-> [CtrlAttribute] -> [(Int, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map CtrlAttribute -> (Int, ByteString)
ctrlAttributesToAttribute [CtrlAttribute]
attrs


-- Hardcoding the request ID is not the most elegant, but shouldn't be a problem
-- since the family should be obvious in the answer
familyMcastRequest :: Word16 -> CTRLPacket
familyMcastRequest :: Word16 -> CTRLPacket
familyMcastRequest Word16
fid = let
  header :: Header
header = MessageType -> Word16 -> Word32 -> Word32 -> Header
Header MessageType
16 Word16
forall a. (Num a, Bits a) => a
fNLM_F_REQUEST Word32
42 Word32
0
  geheader :: GenlHeader
geheader = Word8 -> Word8 -> GenlHeader
GenlHeader Word8
forall a. Num a => a
eCTRL_CMD_GETFAMILY Word8
0
  attrs :: Attributes
attrs = [(Int, ByteString)] -> Attributes
forall k a. Ord k => [(k, a)] -> Map k a
fromList [(Int
forall a. Num a => a
eCTRL_ATTR_FAMILY_ID, Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$Putter Word16
putWord16host Word16
fid)] in
    Header -> GenlData NoData -> Attributes -> CTRLPacket
forall a. Header -> a -> Attributes -> Packet a
Packet Header
header (GenlHeader -> NoData -> GenlData NoData
forall a. GenlHeader -> a -> GenlData a
GenlData GenlHeader
geheader NoData
NoData) Attributes
attrs


familyIdRequest :: String -> CTRLPacket
familyIdRequest :: [Char] -> CTRLPacket
familyIdRequest [Char]
name = let
  header :: Header
header = MessageType -> Word16 -> Word32 -> Word32 -> Header
Header MessageType
16 Word16
forall a. (Num a, Bits a) => a
fNLM_F_REQUEST Word32
33 Word32
0
  geheader :: GenlHeader
geheader = Word8 -> Word8 -> GenlHeader
GenlHeader Word8
forall a. Num a => a
eCTRL_CMD_GETFAMILY Word8
0
  attrs :: Attributes
attrs = [(Int, ByteString)] -> Attributes
forall k a. Ord k => [(k, a)] -> Map k a
fromList [(Int
forall a. Num a => a
eCTRL_ATTR_FAMILY_NAME, [Char] -> ByteString
pack [Char]
name ByteString -> ByteString -> ByteString
`append` [Char] -> ByteString
pack [Char]
"\0")] in
    Header -> GenlData NoData -> Attributes -> CTRLPacket
forall a. Header -> a -> Attributes -> Packet a
Packet Header
header (GenlHeader -> NoData -> GenlData NoData
forall a. GenlHeader -> a -> GenlData a
GenlData GenlHeader
geheader NoData
NoData) Attributes
attrs

-- |A safe version of 'getFamilyId'
getFamilyIdS :: NetlinkSocket -> String -> IO (Maybe Word16)
getFamilyIdS :: NetlinkSocket -> [Char] -> IO (Maybe Word16)
getFamilyIdS NetlinkSocket
s [Char]
m = do
  may <- NetlinkSocket
-> [Char] -> IO (Maybe (Word16, [CtrlAttrMcastGroup]))
getFamilyWithMulticastsS NetlinkSocket
s [Char]
m
  return $fmap fst may

-- |A safe version of 'getFamilyWithMulticasts'
getFamilyWithMulticastsS :: NetlinkSocket -> String -> IO (Maybe (Word16, [CtrlAttrMcastGroup]))
getFamilyWithMulticastsS :: NetlinkSocket
-> [Char] -> IO (Maybe (Word16, [CtrlAttrMcastGroup]))
getFamilyWithMulticastsS NetlinkSocket
s [Char]
m = do
  packet <- NetlinkSocket -> CTRLPacket -> IO CTRLPacket
forall a.
(Convertable a, Eq a, Show a) =>
NetlinkSocket -> Packet a -> IO (Packet a)
queryOne NetlinkSocket
s ([Char] -> CTRLPacket
familyIdRequest [Char]
m)
  let ctrl = CTRLPacket -> Maybe CtrlPacket
ctrlPacketFromGenl CTRLPacket
packet
  return $ makeTupl . ctrlAttributes <$> ctrl
  where getIdFromList :: [CtrlAttribute] -> Word16
getIdFromList (CTRL_ATTR_FAMILY_ID Word16
x:[CtrlAttribute]
_) = Word16
x
        getIdFromList (CtrlAttribute
_:[CtrlAttribute]
xs) = [CtrlAttribute] -> Word16
getIdFromList [CtrlAttribute]
xs
        getIdFromList [] = -Word16
1
        makeTupl :: [CtrlAttribute] -> (Word16, [CtrlAttrMcastGroup])
makeTupl [CtrlAttribute]
attrs = ([CtrlAttribute] -> Word16
getIdFromList [CtrlAttribute]
attrs, [CtrlAttribute] -> [CtrlAttrMcastGroup]
getMCFromList [CtrlAttribute]
attrs)

-- |Get the id for a netlink family by name
getFamilyId :: NetlinkSocket -> String -> IO Word16
getFamilyId :: NetlinkSocket -> [Char] -> IO Word16
getFamilyId = (IO (Word16, [CtrlAttrMcastGroup]) -> IO Word16)
-> ([Char] -> IO (Word16, [CtrlAttrMcastGroup]))
-> [Char]
-> IO Word16
forall a b. (a -> b) -> ([Char] -> a) -> [Char] -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Word16, [CtrlAttrMcastGroup]) -> Word16)
-> IO (Word16, [CtrlAttrMcastGroup]) -> IO Word16
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Word16, [CtrlAttrMcastGroup]) -> Word16
forall a b. (a, b) -> a
fst) (([Char] -> IO (Word16, [CtrlAttrMcastGroup]))
 -> [Char] -> IO Word16)
-> (NetlinkSocket -> [Char] -> IO (Word16, [CtrlAttrMcastGroup]))
-> NetlinkSocket
-> [Char]
-> IO Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetlinkSocket -> [Char] -> IO (Word16, [CtrlAttrMcastGroup])
getFamilyWithMulticasts

-- |get the id and multicast groups of a netlink family by name
getFamilyWithMulticasts :: NetlinkSocket -> String -> IO (Word16, [CtrlAttrMcastGroup])
getFamilyWithMulticasts :: NetlinkSocket -> [Char] -> IO (Word16, [CtrlAttrMcastGroup])
getFamilyWithMulticasts NetlinkSocket
s [Char]
m = do
  may <- NetlinkSocket
-> [Char] -> IO (Maybe (Word16, [CtrlAttrMcastGroup]))
getFamilyWithMulticastsS NetlinkSocket
s [Char]
m
  return $fromMaybe (error "Could not find family") may


-- |Get the 'CtrlPacket' describing a single family
getFamilie :: NetlinkSocket -> String -> IO (Maybe CtrlPacket)
getFamilie :: NetlinkSocket -> [Char] -> IO (Maybe CtrlPacket)
getFamilie NetlinkSocket
sock [Char]
name =
  CTRLPacket -> Maybe CtrlPacket
ctrlPacketFromGenl (CTRLPacket -> Maybe CtrlPacket)
-> IO CTRLPacket -> IO (Maybe CtrlPacket)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetlinkSocket -> CTRLPacket -> IO CTRLPacket
forall a.
(Convertable a, Eq a, Show a) =>
NetlinkSocket -> Packet a -> IO (Packet a)
queryOne NetlinkSocket
sock ([Char] -> CTRLPacket
familyIdRequest [Char]
name)

-- |Get 'CtrlPacket's for every currently registered GeNetlink family
getFamilies :: NetlinkSocket -> IO [CtrlPacket]
getFamilies :: NetlinkSocket -> IO [CtrlPacket]
getFamilies NetlinkSocket
sock = do
  (CTRLPacket -> Maybe CtrlPacket) -> [CTRLPacket] -> [CtrlPacket]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe CTRLPacket -> Maybe CtrlPacket
ctrlPacketFromGenl ([CTRLPacket] -> [CtrlPacket])
-> IO [CTRLPacket] -> IO [CtrlPacket]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NetlinkSocket -> CTRLPacket -> IO [CTRLPacket]
forall a.
(Convertable a, Eq a, Show a) =>
NetlinkSocket -> Packet a -> IO [Packet a]
query NetlinkSocket
sock CTRLPacket
familiesRequest
  where familiesRequest :: CTRLPacket
familiesRequest = let header :: Header
header = MessageType -> Word16 -> Word32 -> Word32 -> Header
Header MessageType
16 (Word16
forall a. (Num a, Bits a) => a
fNLM_F_REQUEST Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word16
forall a. (Num a, Bits a) => a
fNLM_F_ROOT Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word16
forall a. (Num a, Bits a) => a
fNLM_F_MATCH) Word32
33 Word32
0
                              geheader :: GenlHeader
geheader = Word8 -> Word8 -> GenlHeader
GenlHeader Word8
forall a. Num a => a
eCTRL_CMD_GETFAMILY Word8
0
                              attrs :: Map Int a
attrs = [(Int, a)] -> Map Int a
forall k a. Ord k => [(k, a)] -> Map k a
fromList [] in
                            Header -> GenlData NoData -> Attributes -> CTRLPacket
forall a. Header -> a -> Attributes -> Packet a
Packet Header
header (GenlHeader -> NoData -> GenlData NoData
forall a. GenlHeader -> a -> GenlData a
GenlData GenlHeader
geheader NoData
NoData) Attributes
forall {a}. Map Int a
attrs


-- |get the mutlicast groups of a netlink family by id
getMulticastGroups :: NetlinkSocket -> Word16 -> IO [CtrlAttrMcastGroup]
getMulticastGroups :: NetlinkSocket -> Word16 -> IO [CtrlAttrMcastGroup]
getMulticastGroups NetlinkSocket
sock Word16
fid = do
  packet <- NetlinkSocket -> CTRLPacket -> IO CTRLPacket
forall a.
(Convertable a, Eq a, Show a) =>
NetlinkSocket -> Packet a -> IO (Packet a)
queryOne NetlinkSocket
sock (Word16 -> CTRLPacket
familyMcastRequest Word16
fid)
  let (CtrlPacket _ _ attrs) = fromMaybe (error "Got infalid family id for request") . ctrlPacketFromGenl $packet
  return $getMCFromList attrs

getMCFromList :: [CtrlAttribute] -> [CtrlAttrMcastGroup]
getMCFromList :: [CtrlAttribute] -> [CtrlAttrMcastGroup]
getMCFromList (CTRL_ATTR_MCAST_GROUPS [CtrlAttrMcastGroup]
x:[CtrlAttribute]
_) = [CtrlAttrMcastGroup]
x
getMCFromList (CtrlAttribute
_:[CtrlAttribute]
xs) = [CtrlAttribute] -> [CtrlAttrMcastGroup]
getMCFromList [CtrlAttribute]
xs
getMCFromList [] = []

-- |Get id of multicast group by name
getMulticast :: String -> [CtrlAttrMcastGroup] -> Maybe Word32
getMulticast :: [Char] -> [CtrlAttrMcastGroup] -> Maybe Word32
getMulticast [Char]
_ [] = Maybe Word32
forall a. Maybe a
Nothing
getMulticast [Char]
name (CAMG [Char]
gname Word32
gid:[CtrlAttrMcastGroup]
xs) = if [Char]
name [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
gname
   then Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
gid
   else [Char] -> [CtrlAttrMcastGroup] -> Maybe Word32
getMulticast [Char]
name [CtrlAttrMcastGroup]
xs