{-# 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 -> String
grpName :: String, CtrlAttrMcastGroup -> Word32
grpId :: Word32 } deriving (CtrlAttrMcastGroup -> CtrlAttrMcastGroup -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CtrlAttrMcastGroup -> CtrlAttrMcastGroup -> Bool
$c/= :: CtrlAttrMcastGroup -> CtrlAttrMcastGroup -> Bool
== :: CtrlAttrMcastGroup -> CtrlAttrMcastGroup -> Bool
$c== :: CtrlAttrMcastGroup -> CtrlAttrMcastGroup -> Bool
Eq, Int -> CtrlAttrMcastGroup -> ShowS
[CtrlAttrMcastGroup] -> ShowS
CtrlAttrMcastGroup -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CtrlAttrMcastGroup] -> ShowS
$cshowList :: [CtrlAttrMcastGroup] -> ShowS
show :: CtrlAttrMcastGroup -> String
$cshow :: CtrlAttrMcastGroup -> String
showsPrec :: Int -> CtrlAttrMcastGroup -> ShowS
$cshowsPrec :: Int -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CtrlAttrOpData -> CtrlAttrOpData -> Bool
$c/= :: CtrlAttrOpData -> CtrlAttrOpData -> Bool
== :: CtrlAttrOpData -> CtrlAttrOpData -> Bool
$c== :: CtrlAttrOpData -> CtrlAttrOpData -> Bool
Eq, Int -> CtrlAttrOpData -> ShowS
[CtrlAttrOpData] -> ShowS
CtrlAttrOpData -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CtrlAttrOpData] -> ShowS
$cshowList :: [CtrlAttrOpData] -> ShowS
show :: CtrlAttrOpData -> String
$cshow :: CtrlAttrOpData -> String
showsPrec :: Int -> CtrlAttrOpData -> ShowS
$cshowsPrec :: Int -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CtrlAttribute -> CtrlAttribute -> Bool
$c/= :: CtrlAttribute -> CtrlAttribute -> Bool
== :: CtrlAttribute -> CtrlAttribute -> Bool
$c== :: CtrlAttribute -> CtrlAttribute -> Bool
Eq, Int -> CtrlAttribute -> ShowS
[CtrlAttribute] -> ShowS
CtrlAttribute -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CtrlAttribute] -> ShowS
$cshowList :: [CtrlAttribute] -> ShowS
show :: CtrlAttribute -> String
$cshow :: CtrlAttribute -> String
showsPrec :: Int -> CtrlAttribute -> ShowS
$cshowsPrec :: Int -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CtrlPacket -> CtrlPacket -> Bool
$c/= :: CtrlPacket -> CtrlPacket -> Bool
== :: CtrlPacket -> CtrlPacket -> Bool
$c== :: CtrlPacket -> CtrlPacket -> Bool
Eq)


instance Show CtrlPacket where
  show :: CtrlPacket -> String
show CtrlPacket
packet = 
    forall a. Show a => a -> String
show (CtrlPacket -> Header
ctrlHeader CtrlPacket
packet) forall a. [a] -> [a] -> [a]
++ Char
'\n'forall a. a -> [a] -> [a]
:forall a. Show a => a -> String
show (CtrlPacket -> GenlHeader
ctrlGeHeader CtrlPacket
packet) forall a. [a] -> [a] -> [a]
++
    String
"Attrs:\n" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
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 = forall a b. Either a b -> Maybe b
e2M (forall a. Get a -> ByteString -> Either String a
runGet Get Word16
g16 ByteString
x)

getW32 :: ByteString -> Maybe Word32
getW32 :: ByteString -> Maybe Word32
getW32 ByteString
x = forall a b. Either a b -> Maybe b
e2M (forall a. Get a -> ByteString -> Either String 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) = forall a. a -> Maybe a
Just b
x
e2M Either a b
_ = forall a. Maybe a
Nothing

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

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

getOpAttr :: (Int, ByteString) -> Maybe CtrlAttrOpData
getOpAttr :: (Int, ByteString) -> Maybe CtrlAttrOpData
getOpAttr (Int
_, ByteString
x) = do
  Attributes
attrs <- forall a b. Either a b -> Maybe b
e2M forall a b. (a -> b) -> a -> b
$forall a. Get a -> ByteString -> Either String a
runGet Get Attributes
getAttributes ByteString
x
  Word32
oid <- ByteString -> Maybe Word32
getW32 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
lookup forall a. Num a => a
eCTRL_ATTR_OP_ID Attributes
attrs
  Word32
ofl <- ByteString -> Maybe Word32
getW32 forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall k a. Ord k => k -> Map k a -> Maybe a
lookup forall a. Num a => a
eCTRL_ATTR_OP_FLAGS Attributes
attrs
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Word32 -> Word32 -> CtrlAttrOpData
CAO Word32
oid Word32
ofl

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

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


ctrlAttributesFromAttributes :: Map Int ByteString -> [CtrlAttribute]
ctrlAttributesFromAttributes :: Attributes -> [CtrlAttribute]
ctrlAttributesFromAttributes = forall a b. (a -> b) -> [a] -> [b]
map (Int, ByteString) -> CtrlAttribute
getAttribute forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) = forall a. a -> Maybe a
Just (Header -> GenlHeader -> [CtrlAttribute] -> CtrlPacket
CtrlPacket Header
h (forall a. GenlData a -> GenlHeader
genlDataHeader GenlData NoData
g) [CtrlAttribute]
a)
  where a :: [CtrlAttribute]
a = Attributes -> [CtrlAttribute]
ctrlAttributesFromAttributes Attributes
attrs
ctrlPacketFromGenl 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) = (forall a. Num a => a
eCTRL_ATTR_UNSPEC      , ByteString
x)
cATA (CTRL_ATTR_FAMILY_ID    Word16
x) = (forall a. Num a => a
eCTRL_ATTR_FAMILY_ID   , Word16 -> ByteString
putW16 Word16
x)
cATA (CTRL_ATTR_FAMILY_NAME  String
x) = (forall a. Num a => a
eCTRL_ATTR_FAMILY_NAME , String -> ByteString
pack (String
x forall a. [a] -> [a] -> [a]
++ String
"\n"))
cATA (CTRL_ATTR_VERSION      Word32
x) = (forall a. Num a => a
eCTRL_ATTR_VERSION     , Word32 -> ByteString
putW32 Word32
x)
cATA (CTRL_ATTR_HDRSIZE      Word32
x) = (forall a. Num a => a
eCTRL_ATTR_HDRSIZE     , Word32 -> ByteString
putW32 Word32
x)
cATA (CTRL_ATTR_MAXATTR      Word32
x) = (forall a. Num a => a
eCTRL_ATTR_MAXATTR     , Word32 -> ByteString
putW32 Word32
x)
cATA (CTRL_ATTR_OPS          [CtrlAttrOpData]
_) = (forall a. Num a => a
eCTRL_ATTR_OPS         , ByteString
empty)
cATA (CTRL_ATTR_MCAST_GROUPS [CtrlAttrMcastGroup]
_) = (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)= forall a. Header -> a -> Attributes -> Packet a
Packet Header
h (forall a. GenlHeader -> a -> GenlData a
GenlData GenlHeader
g NoData
NoData) Attributes
a
  where a :: Attributes
a = forall k a. Ord k => [(k, a)] -> Map k a
fromList forall a b. (a -> b) -> a -> b
$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 forall a. (Num a, Bits a) => a
fNLM_F_REQUEST Word32
42 Word32
0
  geheader :: GenlHeader
geheader = Word8 -> Word8 -> GenlHeader
GenlHeader forall a. Num a => a
eCTRL_CMD_GETFAMILY Word8
0
  attrs :: Attributes
attrs = forall k a. Ord k => [(k, a)] -> Map k a
fromList [(forall a. Num a => a
eCTRL_ATTR_FAMILY_ID, Put -> ByteString
runPut forall a b. (a -> b) -> a -> b
$Putter Word16
putWord16host Word16
fid)] in
    forall a. Header -> a -> Attributes -> Packet a
Packet Header
header (forall a. GenlHeader -> a -> GenlData a
GenlData GenlHeader
geheader NoData
NoData) Attributes
attrs


familyIdRequest :: String -> CTRLPacket
familyIdRequest :: String -> CTRLPacket
familyIdRequest String
name = let
  header :: Header
header = MessageType -> Word16 -> Word32 -> Word32 -> Header
Header MessageType
16 forall a. (Num a, Bits a) => a
fNLM_F_REQUEST Word32
33 Word32
0
  geheader :: GenlHeader
geheader = Word8 -> Word8 -> GenlHeader
GenlHeader forall a. Num a => a
eCTRL_CMD_GETFAMILY Word8
0
  attrs :: Attributes
attrs = forall k a. Ord k => [(k, a)] -> Map k a
fromList [(forall a. Num a => a
eCTRL_ATTR_FAMILY_NAME, String -> ByteString
pack String
name ByteString -> ByteString -> ByteString
`append` String -> ByteString
pack String
"\0")] in
    forall a. Header -> a -> Attributes -> Packet a
Packet Header
header (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 -> String -> IO (Maybe Word16)
getFamilyIdS NetlinkSocket
s String
m = do
  Maybe (Word16, [CtrlAttrMcastGroup])
may <- NetlinkSocket
-> String -> IO (Maybe (Word16, [CtrlAttrMcastGroup]))
getFamilyWithMulticastsS NetlinkSocket
s String
m
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst Maybe (Word16, [CtrlAttrMcastGroup])
may

-- |A safe version of 'getFamilyWithMulticasts'
getFamilyWithMulticastsS :: NetlinkSocket -> String -> IO (Maybe (Word16, [CtrlAttrMcastGroup]))
getFamilyWithMulticastsS :: NetlinkSocket
-> String -> IO (Maybe (Word16, [CtrlAttrMcastGroup]))
getFamilyWithMulticastsS NetlinkSocket
s String
m = do
  CTRLPacket
packet <- forall a.
(Convertable a, Eq a, Show a) =>
NetlinkSocket -> Packet a -> IO (Packet a)
queryOne NetlinkSocket
s (String -> CTRLPacket
familyIdRequest String
m)
  let ctrl :: Maybe CtrlPacket
ctrl = CTRLPacket -> Maybe CtrlPacket
ctrlPacketFromGenl CTRLPacket
packet
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [CtrlAttribute] -> (Word16, [CtrlAttrMcastGroup])
makeTupl forall b c a. (b -> c) -> (a -> b) -> a -> c
. CtrlPacket -> [CtrlAttribute]
ctrlAttributes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe CtrlPacket
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 -> String -> IO Word16
getFamilyId = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst) forall b c a. (b -> c) -> (a -> b) -> a -> c
. NetlinkSocket -> String -> IO (Word16, [CtrlAttrMcastGroup])
getFamilyWithMulticasts

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


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

-- |Get 'CtrlPacket's for every currently registered GeNetlink family
getFamilies :: NetlinkSocket -> IO [CtrlPacket]
getFamilies :: NetlinkSocket -> IO [CtrlPacket]
getFamilies NetlinkSocket
sock = do
  forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe CTRLPacket -> Maybe CtrlPacket
ctrlPacketFromGenl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (forall a. (Num a, Bits a) => a
fNLM_F_REQUEST forall a. Bits a => a -> a -> a
.|. forall a. (Num a, Bits a) => a
fNLM_F_ROOT forall a. Bits a => a -> a -> a
.|. forall a. (Num a, Bits a) => a
fNLM_F_MATCH) Word32
33 Word32
0
                              geheader :: GenlHeader
geheader = Word8 -> Word8 -> GenlHeader
GenlHeader forall a. Num a => a
eCTRL_CMD_GETFAMILY Word8
0
                              attrs :: Map Int a
attrs = forall k a. Ord k => [(k, a)] -> Map k a
fromList [] in
                            forall a. Header -> a -> Attributes -> Packet a
Packet Header
header (forall a. GenlHeader -> a -> GenlData a
GenlData GenlHeader
geheader NoData
NoData) 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
  CTRLPacket
packet <- forall a.
(Convertable a, Eq a, Show a) =>
NetlinkSocket -> Packet a -> IO (Packet a)
queryOne NetlinkSocket
sock (Word16 -> CTRLPacket
familyMcastRequest Word16
fid)
  let (CtrlPacket Header
_ GenlHeader
_ [CtrlAttribute]
attrs) = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"Got infalid family id for request") forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTRLPacket -> Maybe CtrlPacket
ctrlPacketFromGenl forall a b. (a -> b) -> a -> b
$CTRLPacket
packet
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$[CtrlAttribute] -> [CtrlAttrMcastGroup]
getMCFromList [CtrlAttribute]
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 :: String -> [CtrlAttrMcastGroup] -> Maybe Word32
getMulticast String
_ [] = forall a. Maybe a
Nothing
getMulticast String
name (CAMG String
gname Word32
gid:[CtrlAttrMcastGroup]
xs) = if String
name forall a. Eq a => a -> a -> Bool
== String
gname
   then forall a. a -> Maybe a
Just Word32
gid
   else String -> [CtrlAttrMcastGroup] -> Maybe Word32
getMulticast String
name [CtrlAttrMcastGroup]
xs